Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/formcoord.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/bibio/formcoord.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/formcoord.F	(revision 300)
@@ -0,0 +1,51 @@
+      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: LMDZ.3.3/tags/CCM1_0/libf/bibio/initdynav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/initdynav.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/initdynav.F	(revision 300)
@@ -3,4 +3,5 @@
 
        USE IOIPSL
+       USE histcom
 
       implicit none
@@ -118,4 +119,12 @@
      .             32, 'ave(X)', t_ops, t_wrt)
 C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', 7200., 7200.)
+
+
+C
 C  Geopotentiel
 C
Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/initfluxsto.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/bibio/initfluxsto.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/initfluxsto.F	(revision 300)
@@ -0,0 +1,224 @@
+      subroutine initfluxsto
+     .  (infile,tstep,t_ops,t_wrt,nq,
+     .                    fileid,filevid,filedid)
+
+       USE IOIPSL
+       USE histcom
+
+      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   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"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 itau
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid,filedid
+      integer nq,ndex(1)
+      real nivd(1)
+
+C   Variables locales
+C
+      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
+      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 = anne_ini
+      CALL ymds2ju(zan, 1, 1, 0.0, zjulian)
+      zjulian = zjulian + day_ini
+      tau0 = 0
+	
+	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, jjp1, rlat,
+     .             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, jjm, rlat,
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+	
+	rl(1,1) = 1.	
+      call histbeg('defstoke.nc', 1, rl, 1, rl,
+     .             1, 1, 1, 1,
+     .             tau0, zjulian, tstep, dhoriid, filedid)
+
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar',
+     .              'Grille points scalaires', thoriid)
+	
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              llm, nivsigs, zvertiid)
+c pour le fichier def
+      nivd(1) = 1
+      call histvert(filedid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              1, nivd, dvertiid)
+
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+	
+	CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	CALL histdef(filedid, "dtvr", "tps dyn", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+        
+         CALL histdef(filedid, "istdyn", "tps stock", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         
+         CALL histdef(filedid, "istphy", "tps stock phy", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+
+C
+C Masse 
+C
+      call histdef(fileid, 'masse', 'Masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbaru 
+C
+      call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Pbarv 
+C
+      call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
+     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  w 
+C
+      call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C Geopotentiel 
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      call histend(filedid)
+      if (ok_sync) then
+        call histsync(fileid)
+        call histsync(filevid)
+        call histsync(filedid)
+      endif
+	
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/inithist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/inithist.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/inithist.F	(revision 300)
@@ -3,4 +3,5 @@
 
        USE IOIPSL
+       USE histcom
 
       implicit none
Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/writedynav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/writedynav.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/writedynav.F	(revision 300)
@@ -58,5 +58,5 @@
 C   Variables locales
 C
-      integer ndex(1),iq, ii, ll
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
       character*3 str
       real us(ip1jmp1*llm), vs(ip1jmp1*llm)
@@ -68,6 +68,12 @@
 C
       str='q  '
-      ndex(1) = 0
+      ndex3d = 0
+      ndex2d = 0
       ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
 
 C Passage aux composantes naturelles du vent
@@ -81,5 +87,5 @@
       call gr_u_scal(llm, unat, us)
       call histwrite(histid, 'u', time, us, 
-     .               iip1*jjp1*llm, ndex)
+     .               iip1*jjp1*llm, ndex3d)
 C
 C  Vents V scalaire
@@ -87,5 +93,10 @@
       call gr_v_scal(llm, vnat, vs)
       call histwrite(histid, 'v', time, vs, 
-     .               iip1*jjp1*llm, ndex)
+     .               iip1*jjp1*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+      call histwrite(histid, 'theta', time, teta, 
+     .                iip1*jjp1*llm, ndex3d)
 C
 C  Temperature moyennee
@@ -95,10 +106,10 @@
       enddo
       call histwrite(histid, 'temp', time, tm, 
-     .                iip1*jjp1*llm, ndex)
+     .                iip1*jjp1*llm, ndex3d)
 C
 C  Geopotentiel
 C
       call histwrite(histid, 'phi', time, phi, 
-     .                iip1*jjp1*llm, ndex)
+     .                iip1*jjp1*llm, ndex3d)
 C
 C  Traceurs
@@ -112,5 +123,5 @@
           ENDIF
           call histwrite(histid, str, time, q(:,:,iq), 
-     .                   iip1*jjp1*llm, ndex)
+     .                   iip1*jjp1*llm, ndex3d)
         enddo
       endif
@@ -118,17 +129,17 @@
 C  Masse
 C
-       call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex)
+       call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex2d)
 C
 C  Pression au sol
 C
-       call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex)
+       call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex2d)
 C
 C  Geopotentiel au sol
 C
-       call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex)
+       call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex2d)
 C
 C  Fin
 C
-      if (ok_sync) call histsync
+      if (ok_sync) call histsync(histid)
       return
       end
Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/writehist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/writehist.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/writehist.F	(revision 300)
@@ -59,5 +59,6 @@
 C   Variables locales
 C
-      integer ndex(1),iq, ii, ll
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
       character*3 str
       logical ok_sync
@@ -66,5 +67,7 @@
 C
       str='q  '
-      ndex(1) = 0
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
       ok_sync =.TRUE.
 C
@@ -74,5 +77,5 @@
 C
       call histwrite(histid, 'ucov', time, ucov, 
-     .               iip1*jjp1*llm, ndex)
+     .               iip1*jjp1*llm, ndexu)
 
 C
@@ -80,5 +83,5 @@
 C
       call histwrite(histvid, 'vcov', time, vcov, 
-     .               iip1*jjm*llm, ndex)
+     .               iip1*jjm*llm, ndexv)
 
 C
@@ -86,10 +89,10 @@
 C
       call histwrite(histid, 'teta', time, teta, 
-     .                iip1*jjp1*llm, ndex)
+     .                iip1*jjp1*llm, ndexu)
 C
 C  Geopotentiel
 C
       call histwrite(histid, 'phi', time, phi, 
-     .                iip1*jjp1*llm, ndex)
+     .                iip1*jjp1*llm, ndexu)
 C
 C  Traceurs
@@ -103,5 +106,5 @@
           ENDIF
           call histwrite(histid, str, time, q(:,:,iq), 
-     .                   iip1*jjp1*llm, ndex)
+     .                   iip1*jjp1*llm, ndexu)
         enddo
       endif
@@ -109,17 +112,20 @@
 C  Masse
 C
-      call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex)
+      call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex2d)
 C
 C  Pression au sol
 C
-      call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex)
+      call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex2d)
 C
 C  Geopotentiel au sol
 C
-      call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex)
+      call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex2d)
 C
 C  Fin
 C
-      if (ok_sync) call histsync
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+      endif
       return
       end
Index: LMDZ.3.3/tags/CCM1_0/libf/bibio/writephys.F90
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/bibio/writephys.F90	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/bibio/writephys.F90	(revision 300)
@@ -0,0 +1,392 @@
+!
+! $Header$
+!
+  MODULE writephys
+
+!
+! Wrapper d'IOIPSL pour l'ecriture des sorties de la physique. Un seul appel 
+! par variable devrait (?) suffire pour l'initialisation et l'ecriture
+!
+! LF, LMD, 07/2001
+!
+! 2 routines principales:
+!   writephy_ini pour l'initialisation des fichiers (appel histbeg, histvert)
+!   writephy pour l'ecriture des champs (appel histdef, histwrite)
+! dans le futur:
+!   writephy_def pour definir des profils de variables
+! 
+  USE IOIPSL
+
+  IMPLICIT none
+
+  PRIVATE
+  PUBLIC :: writephy_ini, writephy, writephy_def, writephy_sync
+
+!
+! variables locales 
+!
+! nombre de fichiers maximum a ouvrir
+  integer, parameter :: nb_files_max = 20
+! nombre de variables maximum par fichier
+  integer, parameter :: nb_var_max = 500
+! nombre maximum de "profils" de variables
+  integer, parameter :: nb_prof_max = 10
+! structure d'infos sur les fichiers
+  type fichier
+     character*30        :: file_name
+     integer             :: nitau
+     integer             :: file_id
+     integer             :: isize, jsize, lsize, phy_lon
+     integer             :: nhori, nvert
+     logical             :: define
+  end type fichier
+  type (fichier), dimension(nb_files_max), save :: hist_files
+! structure de profils de variables
+  type profils
+     real               :: freq_op
+     real               :: freq_wri
+     character*6        :: var_op
+     integer            :: zsize
+     integer            :: reg_size
+     integer,dimension(:), pointer :: reg_index
+  end type profils 
+  type (profils), dimension(nb_prof_max, nb_files_max), save :: var_profs
+
+! liste des variables par fichier
+  character (len=10), save, dimension(nb_var_max,nb_files_max) :: list_var='undefined'
+! nombre de variables par fichier
+  integer, save, dimension(nb_files_max) :: nb_var = 0 
+! nombre de bits à sauvegarder dans les fichiers
+  integer, save :: nbits = 32
+!
+! Quelques initialisations
+!
+
+  CONTAINS
+
+!
+!###########################################################################
+!
+  SUBROUTINE writephy_ini(nid_file, nom_fichier, klon, iim, jjm, llm, &
+ &                        rlon, rlat, zlev, &
+ &                        date0, dtime)
+!
+! Initialisation des fichiers histoire de la physique
+! Appels a histbeg, histvert
+! Remplissage des structures d'informations sur les fichiers
+! 
+! Entree:
+!   nid_file          numero/index du fichier a initialiser
+!   nom_fichier       nom du fichier
+!   klon              taille des champs physiques
+!   iim, jjm, llm     taille en i,j,k      
+!   rlon, rlat, zlev  coordonnees en x, y, z
+!   date0             date debut
+!   dtime             pas de temps elementaire de la physique 
+!   
+! Declaration des parametres d'entree
+  integer :: nid_file
+  character*(*) :: nom_fichier
+  integer :: iim, jjm, llm, klon
+  real, dimension(klon) :: rlon
+  real, dimension(klon) :: rlat
+  real, dimension(llm) :: zlev
+  real                 :: date0, dtime
+!
+! Variables locales
+!
+  integer :: i, file_id, nvert, nhori
+  real, dimension(iim, jjm) :: temp_lon, temp_lat
+  logical, save             :: first_call = .true.
+  integer,parameter         :: nulou = 6
+!
+! Quelques initialisations
+!
+  if (first_call) then
+    hist_files(:)%define = .true.
+    var_profs(:,:)%freq_wri = -999
+    hist_files(:)%nitau = 1
+    first_call= .false.
+  endif
+!
+! Mise des coordonnees sur une grille 2D
+!
+  call gr_fi_ecrit(1,klon,iim,jjm,rlon,temp_lon)
+  do i = 1, iim 
+    temp_lon(i,1) = rlon(i+1)
+    temp_lon(i,jjm) = rlon(i+1)
+  enddo
+  call gr_fi_ecrit(1,klon,iim,jjm,rlat,temp_lat)
+!
+! Initialisation du fichier
+!
+  call histbeg(nom_fichier, iim, temp_lon, jjm, temp_lat, &
+     &                 1, iim, 1, jjm, 0, date0, dtime, &
+     &                 nhori, file_id)
+  call histvert(file_id, "presnivs", "Vertical levels", "mb", &
+     &                 llm, zlev, nvert)
+
+!
+! Remplissage des infos
+!
+  hist_files(nid_file)%file_name = nom_fichier
+  hist_files(nid_file)%file_id = file_id
+  hist_files(nid_file)%isize = iim
+  hist_files(nid_file)%jsize = jjm
+  hist_files(nid_file)%lsize = llm
+  hist_files(nid_file)%phy_lon = klon
+  hist_files(nid_file)%nhori = nhori
+  hist_files(nid_file)%nvert = nvert
+
+  write(nulou,*)'####################################'
+  write(nulou,*)' Definition du fichier no ',nid_file
+  write(nulou,*)'    nom du fichier     ',hist_files(nid_file)%file_name
+  write(nulou,*)'    identifiant        ',hist_files(nid_file)%file_id
+  write(nulou,*)'    taille en i        ',hist_files(nid_file)%isize
+  write(nulou,*)'    taille en j        ',hist_files(nid_file)%jsize
+  write(nulou,*)'    taille en l        ',hist_files(nid_file)%lsize
+
+!
+  END SUBROUTINE writephy_ini
+!
+!###########################################################################
+!
+  SUBROUTINE writephy_def(profil_n, nid_file,               &
+ &                        var_op, freq_op, freq_wri, zsize, &
+ &                        reg_size, reg_index)
+!
+! Definition de profil type de sortie de variables 
+!               (moyenne, instantanee, indexee ...)
+!
+! Parametres d'entree
+!   profil_n      numero du profil-type
+!   nid_file      numero de fichier
+!   var_op        operation a effectuer sur la variable 
+!   freq_op       frequence de l'operation
+!   freq_wri      frequence d'ecriture
+!   zsize         variable 2D/3D
+!   reg_size      taille de la region a sortir
+!   reg_index     indices de la region a sortir
+!
+  integer                         :: profil_n
+  integer                         :: nid_file
+  character*(*)             :: var_op
+  real                            :: freq_op, freq_wri
+  integer                         :: zsize
+  integer, optional               :: reg_size
+  integer, dimension(*), optional :: reg_index
+!
+! variables locales
+!
+  character (len = 20) :: modname = 'writephy_def'
+  character (len = 80) :: message
+  integer              :: dummy_size
+  integer              :: error 
+  integer,parameter    :: nulou = 6
+!
+! Differentes verif
+!
+  if (profil_n > nb_prof_max) then
+    message = 'numero de profil de variable > nbre maximal de profil'
+    call abort_gcm(modname, message, 1)
+  endif
+  if (var_profs(profil_n, nid_file)%freq_wri /= -999) then
+    message = 'numero de profil deja attribue'
+    call abort_gcm(modname, message, 1)
+  endif        
+!
+! Remplissage structure infos
+!
+  var_profs(profil_n, nid_file)%var_op = var_op
+  var_profs(profil_n, nid_file)%freq_op = freq_op
+  var_profs(profil_n, nid_file)%freq_wri = freq_wri
+  var_profs(profil_n, nid_file)%zsize = zsize
+!
+! test pour region
+!
+  if (present (reg_size)) then
+    if ( .not. present (reg_index)) then
+      message = 'reg_size defini mais pas de region definie'
+      call abort_gcm(modname, message, 1)
+    endif
+    allocate(var_profs(profil_n, nid_file)%reg_index(reg_size), stat = error)
+    if (error /= 0) then
+      message='Pb allocation reg_index'
+      call abort_gcm(modname,message,1)
+    endif
+    var_profs(profil_n, nid_file)%reg_size = reg_size
+    var_profs(profil_n, nid_file)%reg_index = reg_index(1:reg_size)
+  else
+    dummy_size = 1
+    allocate(var_profs(profil_n, nid_file)%reg_index(dummy_size), stat = error)
+    if (error /= 0) then
+      message='Pb allocation reg_index'
+      call abort_gcm(modname,message,1)
+    endif
+    var_profs(profil_n, nid_file)%reg_size = dummy_size
+    var_profs(profil_n, nid_file)%reg_index = 0
+  endif
+
+  write(nulou,*)' Definition du profil de variable numero ', profil_n
+  write(nulou,*)'                              du fichier ', nid_file
+  write(nulou,*)'     operation               ', &
+ &                    var_profs(profil_n, nid_file)%var_op
+  write(nulou,*)'     frequence d''operation  ', &
+ &                    var_profs(profil_n, nid_file)%freq_op
+  write(nulou,*)'     frequence d''ecriture   ', &
+ &                    var_profs(profil_n, nid_file)%freq_wri
+  write(nulou,*)'     2D/3D                   ', &
+ &                    var_profs(profil_n, nid_file)%zsize
+  write(nulou,*)'     taille de la region     ', &
+ &                    var_profs(profil_n, nid_file)%reg_size
+
+  END SUBROUTINE writephy_def
+!
+!###########################################################################
+!
+! A faire: rendre var_title et var_units optionels par lecture d'un tableau
+!
+!
+  SUBROUTINE writephy(file, iprof, var_name, data, var_title, var_units)
+!
+! Definition et ecriture des variables
+!
+! file             numero du fichier dans lequel ecrire
+! iprof            profil de la variable a ecrire
+! var_name         nom de la variable a ecrire
+! data             les donnees effectives a ecrire  
+! var_title        "vrai" nom de la variable, optionel, si non present 
+!                  interrogation d'un tableau
+! var_units        unite de la variable, optionel, si non present 
+!                  interrogation d'un tableau
+
+  integer              :: file, iprof
+  character*(*)        :: var_name
+  real, dimension(*)   :: data
+  character*(*)        :: var_title
+  character*(*)        :: var_units
+!
+! variables locales
+!
+  integer              :: i, error
+  character (len=6)    :: var_op
+  real                 :: freq_op, freq_wri
+  integer              :: file_id, isize, jsize, lsize, phy_lon, zsize
+  integer              :: nhori, nvert, klon
+  integer              :: itau
+  real, dimension(:,:,:), allocatable :: temp_data
+  character (len = 20) :: modname = 'writephy'
+  character (len = 80) :: message
+!
+! Test: toujours en mode definition des variables?
+!
+  if (var_name == list_var(1, file)) then
+    hist_files(file)%nitau = hist_files(file)%nitau + 1
+  endif
+  if (hist_files(file)%define) then
+    if (var_name == list_var(1, file)) then
+!     on a fait le tour des variables
+      hist_files(file)%define = .false.
+      call histend(hist_files(file)%file_id)
+    else
+!
+! pour que l'appel a histdef soit plus lisible, on range tout dans des tampons
+!
+      file_id = hist_files(file)%file_id
+      isize = hist_files(file)%isize
+      jsize = hist_files(file)%jsize    
+      nhori = hist_files(file)%nhori
+      klon = hist_files(file)%phy_lon
+      var_op = var_profs(iprof, file)%var_op
+      freq_op = var_profs(iprof, file)%freq_op
+      freq_wri = var_profs(iprof, file)%freq_wri
+      if (var_profs(iprof, file)%zsize == 0) then
+        lsize = 1
+        nvert = -99
+      else
+        lsize = hist_files(file)%lsize
+        nvert = hist_files(file)%nvert
+      endif
+!      if (var_name == 'phis') then
+!        write(*,*)'Define: ',var_name
+!        write(*,*)file_id, var_name, var_title, var_units,  &
+! &                isize, jsize, nhori, lsize, 1, lsize, nvert, nbits,  &
+! &                var_op, freq_op, freq_wri
+!      endif
+      call histdef(file_id, var_name, var_title, var_units,  &
+ &                isize, jsize, nhori, lsize, 1, lsize, nvert, nbits,  &
+ &                var_op, freq_op, freq_wri)
+      nb_var(file) = nb_var(file) + 1
+      list_var(nb_var(file), file) = var_name
+    endif
+  endif
+!
+! On ecrit la variable
+!
+! Preparation
+!
+  file_id = hist_files(file)%file_id
+  isize = hist_files(file)%isize
+  jsize = hist_files(file)%jsize    
+  nhori = hist_files(file)%nhori
+  var_op = var_profs(iprof, file)%var_op
+  freq_op = var_profs(iprof, file)%freq_op
+  freq_wri = var_profs(iprof, file)%freq_wri
+  itau = hist_files(file)%nitau
+
+  if (var_profs(iprof, file)%zsize == 0) then
+    lsize = 1
+  else
+    lsize = hist_files(file)%lsize
+  endif
+  allocate(temp_data(isize,jsize,lsize), stat = error)
+  if (error /= 0) then
+    message='Pb allocation temp_data'
+    call abort_gcm(modname, message, 1)
+  endif
+!
+! Ecriture
+!
+  call gr_fi_ecrit(lsize, klon, isize, jsize, data, temp_data)
+  if (var_name == 'tsol') then
+    write(*,*)'writephys itau = ', file_id, var_name, itau
+!    write(*,*)file_id, var_name,itau,temp_data, &
+! &               var_profs(iprof, file)%reg_size, &
+! &               var_profs(iprof, file)%reg_index
+  endif
+  call histwrite(file_id, var_name,itau,temp_data, &
+ &               var_profs(iprof, file)%reg_size, &
+ &               var_profs(iprof, file)%reg_index)
+
+  deallocate(temp_data)
+ 
+  return
+!
+  END SUBROUTINE writephy 
+!
+!###########################################################################
+!
+  SUBROUTINE writephy_sync(nid_file)
+!
+! Flush des donnees dans le fichier et eventuellement fermeture du 
+! mode 'define'
+!
+! Entree:
+!   nid_file    numero du fichier a traiter
+!
+  integer     :: nid_file
+!
+  if (hist_files(nid_file)%define) then
+    call histend(hist_files(nid_file)%file_id)
+    hist_files(nid_file)%define = .false.
+  endif
+
+  call histsync(hist_files(nid_file)%file_id)
+  
+return
+
+  END SUBROUTINE writephy_sync 
+!
+!###########################################################################
+!
+  END MODULE writephys
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/abort_gcm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/abort_gcm.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/abort_gcm.F	(revision 300)
@@ -1,2 +1,5 @@
+c
+c $Header$
+c
       SUBROUTINE abort_gcm(modname, message, ierr)
      
@@ -16,4 +19,6 @@
       write(*,*) 'in abort_gcm'
       call histclo
+      call restclo
+c     call getin_dump
 c     call histclo(2)
 c     call histclo(3)
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/addfi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/addfi.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/addfi.F	(revision 300)
@@ -67,6 +67,7 @@
       REAL xpn(iim),xps(iim),tpn,tps
       INTEGER j,k,iq,ij
-      REAL qtest
-      PARAMETER ( qtest = 1.0e-30 )
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      PARAMETER ( qtestt = 1.0e-40 )
 
       REAL SSUM
@@ -81,19 +82,17 @@
       ENDDO
 
-      IF( alphax.NE.0. )   THEN
-        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  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
-      ENDIF
+       DO ij   = 1, iip1
+         pteta(   ij   ,k)  = tpn
+         pteta(ij+ip1jm,k)  = tps
+       ENDDO
+      ENDDO
 c
 
@@ -114,13 +113,19 @@
          pps(j) = pps(j) + pdpfi(j) * pdt
       ENDDO
-
-c
-
-      DO iq = 1, nq
+ 
+      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), qtest )
-ccc              pq(j,k,iq)=qtest
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+            ENDDO
+         ENDDO
+      ENDDO
+
+      DO iq = 3, nq
+         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
@@ -128,37 +133,32 @@
 
 
-      IF( alphax.NE.0. )   THEN
+      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, iim
-          xpn(ij) = aire(   ij   ) * pps(  ij     )
-          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
-         ENDDO
+      DO ij   = 1, iip1
+        pps (   ij     )  = tpn
+        pps ( ij+ip1jm )  = tps
+      ENDDO
+
+
+      DO iq = 1, nq
+        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
-          pps (   ij     )  = tpn
-          pps ( ij+ip1jm )  = tps
-         ENDDO
-
-
-       DO iq = 1, nq
-         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
+          DO ij   = 1, iip1
             pq (   ij   ,k,iq)  = tpn
             pq (ij+ip1jm,k,iq)  = tps
-           ENDDO
-         ENDDO
-       ENDDO
-
-      ENDIF
-
+          ENDDO
+        ENDDO
+      ENDDO
 
       RETURN
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/calfis.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/calfis.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/calfis.F	(revision 300)
@@ -1,2 +1,5 @@
+C
+C $Header$
+C
       SUBROUTINE calfis(nq, lafin, rdayvrai,rday_ecri, heure,
      $            pucov,pvcov,pteta,pq,pmasse,pps,pp,ppk,pphis,pphi,
@@ -128,4 +131,5 @@
       REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqmx)
       REAL zdpsrf(ngridmx)
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
 c
       REAL zsin(iim),zcos(iim),z1(iim)
@@ -141,4 +145,5 @@
       REAL latfi(ngridmx),lonfi(ngridmx)
       REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
 
       LOGICAL firstcal, debut
@@ -176,12 +181,18 @@
          latfi(1)=rlatu(1)
          lonfi(1)=0.
+         zcufi(1) = cu(1,1)
+         zcvfi(1) = cv(1,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(i,j)
+               zcvfi((j-2)*iim+1+i) = cv(i,j)
      	    ENDDO
          ENDDO
          latfi(ngridmx)= rlatu(jjp1)
          lonfi(ngridmx)= 0.
+         zcufi(ngridmx) = cu(1,jjp1)
+         zcvfi(ngridmx) = cv(1,jjm)
          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
           PRINT*,'WARNING!!! vitesse verticale nulle dans la physique'
@@ -311,13 +322,13 @@
 c
       DO l=1,llm
-        pvervel(1,l)=pw(1,1,l)/apoln
+        pvervel(1,l)=pw(1,1,l) * g /apoln
         ig0=2
        DO j=2,jjm
            DO i = 1, iim
-              pvervel(ig0,l) = pw(i,j,l) * unsaire(i,j)
+              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
               ig0 = ig0 + 1
            ENDDO
        ENDDO
-        pvervel(ig0,l)=pw(1,jjp1,l)/apols
+        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
       ENDDO
 
@@ -425,10 +436,11 @@
 
 
-      CALL physiq (ngridmx,llm,nq,debut,lafin,
-     ,   rdayvrai,rday_ecri,heure,dtphys,zplev,zplay,zphi,zphis,airefi,
-     ,             presnivs,clesphy0,  zufi, zvfi,ztfi, zqfi,  
-     ,             pcvgu, pcvgv, pcvgt, pcvgq, pvervel,
+      CALL physiq (ngridmx, llm, nq,
+     ,    debut, lafin, rdayvrai, rday_ecri, heure, dtphys,
+     ,    zplev, zplay, zphi, zphis, airefi, presnivs, clesphy0,
+     ,    zufi, zvfi, ztfi, zqfi,  
+     ,    pvervel, zcufi, zcvfi,
 C - sorties
-     s             zdufi, zdvfi, zdtfi, zdqfi,zdpsrf              )
+     s    zdufi, zdvfi, zdtfi, zdqfi,zdpsrf              )
 
 500   CONTINUE
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/coefpoly.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/coefpoly.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/coefpoly.F	(revision 300)
@@ -0,0 +1,38 @@
+c $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*8 Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL*8 Xfout, Xprim
+      REAL*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: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/comvert.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comvert.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/comvert.h	(revision 300)
@@ -3,5 +3,5 @@
 
       COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm) ,
-     ,               pa,preff,nivsigs(llm),nivsig(llmp1)
+     ,               pa,preff,nivsigs(llm),nivsig(llm+1)
 
       REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/conf_gcm.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/conf_gcm.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/conf_gcm.F	(revision 300)
@@ -0,0 +1,723 @@
+c
+c $Header$
+c
+      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
+c
+      use IOIPSL
+      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 "control.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-----------------------------------------------------------------------
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 181
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=181
+      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  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno 
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps) 
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+
+!Config  Key  = 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  = idissip
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 10
+!Config  Help = periode de la dissipation 
+!Config         (en pas) ... a completer !
+       idissip = 10
+       CALL getin('idissip',idissip)
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+!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)
+
+c    ...............................................................
+
+!Config  Key  = physic
+!Config  Desc = Avec ls physique 
+!Config  Def  = y
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       physic = .TRUE.
+       CALL getin('physic',physic)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+
+!Config  Key  = ecritphy
+!Config  Desc = Frequence d'ecriture de la physique
+!Config  Def  = 1
+!Config  Help = frequence  de l'ecriture du fichier histphy
+!Config         en jours.
+       ecritphy = 1
+       CALL getin('ecritphy',ecritphy)
+
+!Config  Key  = cycle_diurne
+!Config  Desc = Cycle ddiurne
+!Config  Def  = y
+!Config  Help = Cette option permet d'eteidre le cycle diurne.
+!Config         Peut etre util pour accelerer le code !
+       cycle_diurne = .TRUE.
+       CALL getin('cycle_diurne',cycle_diurne)
+
+!Config  Key  = soil_model
+!Config  Desc = Modele de sol
+!Config  Def  = y
+!Config  Help = Choix du modele de sol (Thermique ?)
+!Config         Option qui pourait un string afin de pouvoir
+!Config         plus de choix ! Ou meme une liste d'options !
+       soil_model = .TRUE.
+       CALL getin('soil_model',soil_model)
+
+!Config  Key  = new_oliq
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = y
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       new_oliq = .TRUE.
+       CALL getin('new_oliq',new_oliq)
+
+!Config  Key  = ok_orodr
+!Config  Desc = Orodr ???
+!Config  Def  = y
+!Config  Help = Y en a pas comprendre !
+!Config         
+       ok_orodr = .TRUE.
+       CALL getin('ok_orodr',ok_orodr)
+
+!Config  Key  =  ok_orolf
+!Config  Desc = Orolf ??
+!Config  Def  = y
+!Config  Help = Connais pas !
+       ok_orolf = .TRUE.
+       CALL getin('ok_orolf', ok_orolf)
+
+!Config  Key  = ok_limitvrai
+!Config  Desc = Force la lecture de la bonne annee
+!Config  Def  = n
+!Config  Help = On peut forcer le modele a lire le
+!Config         fichier SST de la bonne annee. C'est une tres bonne
+!Config         idee, pourquoi ne pas mettre toujours a y ???
+       ok_limitvrai = .FALSE.
+       CALL getin('ok_limitvrai',ok_limitvrai)
+
+!Config  Key  = nbapp_rad
+!Config  Desc = Frequence d'appel au rayonnement
+!Config  Def  = 12
+!Config  Help = Nombre  d'appels des routines de rayonnements
+!Config         par jour.
+       nbapp_rad = 12
+       CALL getin('nbapp_rad',nbapp_rad)
+
+!Config  Key  = iflag_con
+!Config  Desc = Flag de convection
+!Config  Def  = 2
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         1 pour LMD,
+!Config         2 pour Tiedtke,
+!Config         3 pour CCM(NCAR)  
+       iflag_con = 2
+       CALL getin('iflag_con',iflag_con)
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = FLOAT( iflag_con )
+                          clesphy0(2) = FLOAT( 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
+
+!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
+        PRINT *,' 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
+        PRINT *,' 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
+        PRINT *,' La valeur de grossismy passee par run.def est differen
+     * te de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** fxyhypb lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  fxyhypb lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+      ENDIF
+c
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        PRINT *,' 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
+        PRINT *,' 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
+        PRINT *,' 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
+        PRINT *,' 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
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' *** ysinus lu sur le fichier start est F ',
+     *       'alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
+              PRINT *,' ***  ysinus lu sur le fichier start est T ',
+     *        'alors  qu il est  F  sur  run.def  ****  '
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+
+      write(tapeout,*)' #########################################'
+      write(tapeout,*)' Configuration des parametres du gcm: '
+      write(tapeout,*)' dayref = ', dayref
+      write(tapeout,*)' anneeref = ', anneeref
+      write(tapeout,*)' nday = ', nday
+      write(tapeout,*)' day_step = ', day_step
+      write(tapeout,*)' iperiod = ', iperiod
+      write(tapeout,*)' iconser = ', iconser
+      write(tapeout,*)' iecri = ', iecri
+      write(tapeout,*)' periodav = ', periodav 
+      write(tapeout,*)' idissip = ', idissip
+      write(tapeout,*)' lstardis = ', lstardis
+      write(tapeout,*)' nitergdiv = ', nitergdiv
+      write(tapeout,*)' nitergrot = ', nitergrot
+      write(tapeout,*)' niterh = ', niterh
+      write(tapeout,*)' tetagdiv = ', tetagdiv
+      write(tapeout,*)' tetagrot = ', tetagrot
+      write(tapeout,*)' tetatemp = ', tetatemp
+      write(tapeout,*)' coefdis = ', coefdis
+      write(tapeout,*)' purmats = ', purmats
+      write(tapeout,*)' physic = ', physic
+      write(tapeout,*)' iphysiq = ', iphysiq
+      write(tapeout,*)' ecritphy = ', ecritphy
+      write(tapeout,*)' cycle_diurne = ', cycle_diurne
+      write(tapeout,*)' soil_model = ', soil_model
+      write(tapeout,*)' new_oliq = ', new_oliq
+      write(tapeout,*)' ok_orodr = ', ok_orodr
+      write(tapeout,*)' ok_orolf = ', ok_orolf
+      write(tapeout,*)' ok_limitvrai = ', ok_limitvrai
+      write(tapeout,*)' nbapp_rad = ', nbapp_rad
+      write(tapeout,*)' iflag_con = ', iflag_con
+      write(tapeout,*)' clonn = ', clonn 
+      write(tapeout,*)' clatt = ', clatt
+      write(tapeout,*)' grossismx = ', grossismx
+      write(tapeout,*)' grossismy = ', grossismy
+      write(tapeout,*)' fxyhypbb = ', fxyhypbb
+      write(tapeout,*)' dzoomxx = ', dzoomxx
+      write(tapeout,*)' dzoomy = ', dzoomyy
+      write(tapeout,*)' tauxx = ', tauxx
+      write(tapeout,*)' tauyy = ', tauyy
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      PRINT *,' alphax alphay defrun ',alphax,alphay
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+c
+
+      write(tapeout,*)' #########################################'
+      write(tapeout,*)' Configuration des parametres du gcm: '
+      write(tapeout,*)' dayref = ', dayref
+      write(tapeout,*)' anneeref = ', anneeref
+      write(tapeout,*)' nday = ', nday
+      write(tapeout,*)' day_step = ', day_step
+      write(tapeout,*)' iperiod = ', iperiod
+      write(tapeout,*)' iconser = ', iconser
+      write(tapeout,*)' iecri = ', iecri
+      write(tapeout,*)' periodav = ', periodav 
+      write(tapeout,*)' idissip = ', idissip
+      write(tapeout,*)' lstardis = ', lstardis
+      write(tapeout,*)' nitergdiv = ', nitergdiv
+      write(tapeout,*)' nitergrot = ', nitergrot
+      write(tapeout,*)' niterh = ', niterh
+      write(tapeout,*)' tetagdiv = ', tetagdiv
+      write(tapeout,*)' tetagrot = ', tetagrot
+      write(tapeout,*)' tetatemp = ', tetatemp
+      write(tapeout,*)' coefdis = ', coefdis
+      write(tapeout,*)' purmats = ', purmats
+      write(tapeout,*)' physic = ', physic
+      write(tapeout,*)' iphysiq = ', iphysiq
+      write(tapeout,*)' ecritphy = ', ecritphy
+      write(tapeout,*)' cycle_diurne = ', cycle_diurne
+      write(tapeout,*)' soil_model = ', soil_model
+      write(tapeout,*)' new_oliq = ', new_oliq
+      write(tapeout,*)' ok_orodr = ', ok_orodr
+      write(tapeout,*)' ok_orolf = ', ok_orolf
+      write(tapeout,*)' ok_limitvrai = ', ok_limitvrai
+      write(tapeout,*)' nbapp_rad = ', nbapp_rad
+      write(tapeout,*)' iflag_con = ', iflag_con
+      write(tapeout,*)' clonn = ', clonn 
+      write(tapeout,*)' clatt = ', clatt
+      write(tapeout,*)' grossismx = ', grossismx
+      write(tapeout,*)' grossismy = ', grossismy
+      write(tapeout,*)' fxyhypbb = ', fxyhypbb
+      write(tapeout,*)' dzoomx = ', dzoomx
+      write(tapeout,*)' dzoomy = ', dzoomy
+      write(tapeout,*)' taux = ', taux
+      write(tapeout,*)' tauy = ', tauy
+c
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/create_limit.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/create_limit.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/create_limit.F	(revision 300)
@@ -1,3 +1,6 @@
+c $Header$
       PROGRAM create_limit
+      USE startvar
+      USE ioipsl
       IMPLICIT none
 c
@@ -13,4 +16,5 @@
 c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
 c                         pour lecture netcdf dans LMDZ.3.3
+c modifie par P. Braconnot pour utiliser la version sous-surfaces
 c-------------------------------------------------------------
 c
@@ -23,20 +27,30 @@
 #include "comgeom2.h"
 #include "comconst.h"
-c
+#include "dimphy.h"
+#include "indicesol.h"
 c-----------------------------------------------------------------------
-      INTEGER KIDIA, KFDIA, KLON, KLEV
-      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
-     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
-c-----------------------------------------------------------------------
-      REAL phy_nat(klon,360), phy_nat0(klon)
+      REAL phy_nat(klon,360)
+      real phy_nat0(klon)
       REAL phy_alb(klon,360)
       REAL phy_sst(klon,360)
       REAL phy_bil(klon,360)
       REAL phy_rug(klon,360)
-      REAL phy_ice(klon,360)
+      REAL phy_ice(klon)
+CPB
+c      REAL phy_icet(klon,360)
+c      REAL phy_oce(klon,360)
+      real pctsrf_t(klon,nbsrf,360)
+      real pctsrf(klon,nbsrf)
+      REAL verif
 c
       REAL masque(iip1,jjp1)
       REAL mask(iim,jjp1)
-
+CPB
+C newlmt indique l'utilisation de la sous-maille fractionnelle
+C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3)
+      LOGICAL newlmt, fracterre
+      PARAMETER(newlmt=.TRUE.)
+      PARAMETER(fracterre = .TRUE.) 
+CPB
 C Declarations pour le champ de depart
       INTEGER imdep, jmdep,lmdep
@@ -52,5 +66,5 @@
       REAL champ_msk(ibid_msk*jbid_msk)
       REAL dlon_msk(ibid_msk), dlat_msk(jbid_msk)
-
+      REAL*4 zbidon(ibid_msk*jbid_msk) 
 C Declarations pour le champ interpole 2D
       REAL champint(iim,jjp1)
@@ -75,8 +89,27 @@
       INTEGER id_tim
       INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
-
-      INTEGER i, j, k, l
+CPB
+      INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
+
+      INTEGER i, j, k, l, ji
+c declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
 c Diverses variables locales
       REAL time
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+
 
       INTEGER          longcles
@@ -86,4 +119,5 @@
       INTEGER ncid,varid,ndimid(4),dimid
       character*30 namedim
+      CHARACTER*80 :: varname
 
 c initialisations:
@@ -100,4 +134,5 @@
       cpp    = 1004.70885
       dtvr    = daysec/FLOAT(day_step)
+
 c
 ccc      CALL iniconst ( non  indispensable )
@@ -108,7 +143,172 @@
 C Traitement du relief au sol
 c
-      write(*,*) 'Traitement du relief au sol pour fabriquer masque'
-      ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
-
+      write(*,*) 'Fabrication masque'
+
+      varname = 'masque'
+      masque(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0)
+      pctsrf=0.
+      varname = 'zmasq'
+      zmasq(:) = 0.
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmasq,0.0)
+      WHERE (zmasq(1 : klon) .LT. EPSFRA)
+          zmasq(1 : klon) = 0.
+      END WHERE 
+      WHERE (1 - zmasq(1 : klon) .LT. EPSFRA)
+          zmasq(1 : klon) = 1.
+      END WHERE 
+!      WRITE(*,*)zmasq
+
+      IF ( fracterre ) THEN
+          DO i = 1, iim
+            masque(i,1) = masque(i,1)
+            masque(i,jjp1) = masque(i,jjp1)
+          END DO
+      ELSE 
+          DO i = 1, iim
+            masque(i,1) = FLOAT(NINT(masque(i,1)))
+            masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
+          END DO
+      ENDIF 
+c$$$      DO i = 1, iim
+c$$$      DO j = 1, jjp1
+c$$$         mask(i,j) = masque(i,j)
+c$$$      ENDDO
+c$$$      ENDDO
+c$$$      CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
+      phy_nat0(1:klon) = zmasq(1:klon)
+      mask = 0.
+      DO j = 1, jjp1
+        DO i = 1, iim
+          IF ( masque(i,j) .GE. EPSFRA) mask (i,j) = 1
+        END DO 
+      END DO  
+C
+C En cas de simulation couplee, lecture du masque ocean issu du modele ocean
+C utilise pour calculer les poids et pour assurer l'adequation entre les
+C fractions d'ocean vu par l'atmosphere et l'ocean
+C
+
+      write(*,*)'Essai de lecture masque ocean'
+      iret = nf_open("o2a.nc", NF_NOWRITE, nid_o2a)
+      if (iret .ne. 0) then
+        write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve'
+        write(*,*)'Run force'
+      else
+        couple = .true.
+        iret = nf_close(nid_o2a)
+        call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp
+     $    , nid_o2a)
+        if (iml_omask /= iim .or. jml_omask /= jjp1) then
+          write(*,*)'Dimensions non compatibles pour masque ocean'
+          write(*,*)'iim = ',iim,' iml_omask = ',iml_omask
+          write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask
+          stop
+        endif
+        ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(dlon_omask(iml_omask), stat=iret)
+        ALLOCATE(dlat_omask(jml_omask), stat=iret)
+        ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret)
+        CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp
+     $    , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid)
+        CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, 
+     $      ttm_tmp, 1, 1, ocetmp)
+        CALL flinclo(fid)
+        dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1)
+        dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask)
+        ocemask = ocetmp
+        if (dlat_omask(1) < dlat_omask(jml_omask)) then
+          do j = 1, jml_omask
+            ocemask(:,j) = ocetmp(:,jml_omask-j+1)
+          enddo
+        endif 
+C
+C passage masque ocean a la grille physique
+C
+        ocemask_fi(1) = ocemask(1,1)
+        do j = 2, jjm
+          do i = 1, iim
+            ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j)
+          enddo
+        enddo
+        ocemask_fi(klon) = ocemask(1,jjp1)
+        zmasq = 1. - ocemask_fi
+      endif
+
+
+C
+C lecture du fichier glace de terre pour fixer la fraction de terre 
+C et de glace de terre
+C
+      CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp
+     $    , fid)
+      ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(dlon_lic(iml_lic), stat=iret)
+      ALLOCATE(dlat_lic(jml_lic), stat=iret)
+      ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret)
+      CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp
+     $    , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
+      CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp
+     $    , 1, 1, fraclic)
+      CALL flinclo(fid)
+C
+C interpolation sur la grille T du modele
+C
+      WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', 
+     $    iml_lic, jml_lic
+c
+C sil les coordonnees sont en degres, on les transforme
+C
+      IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) )  THEN
+          lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180.
+      ENDIF 
+      IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN 
+          lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180.
+      ENDIF 
+
+      dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1)
+      dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) 
+C
+      CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic
+     $    ,iim, jjp1,
+     $    rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1))
+c$$$      flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1)
+      flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1)
+C
+C passage sur la grille physique
+C
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp,
+     $    pctsrf(1:klon, is_lic))
+C adequation avec le maque terre/mer
+      WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) 
+          pctsrf(1 : klon, is_lic) = 0. 
+      END WHERE
+      WHERE (zmasq( 1 : klon) .LT. EPSFRA) 
+          pctsrf(1 : klon, is_lic) = 0.
+      END WHERE 
+      pctsrf(1 : klon, is_ter) = zmasq(1 : klon)
+      DO ji = 1, klon
+        IF (zmasq(ji) .GT. EPSFRA) THEN 
+            IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN
+                pctsrf(ji, is_lic) = zmasq(ji)
+                pctsrf(ji, is_ter) = 0.
+            ELSE 
+                pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic)
+                IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN
+                    pctsrf(ji,is_ter) = 0.
+                    pctsrf(ji, is_lic) = zmasq(ji)
+                ENDIF 
+            ENDIF 
+        ENDIF 
+      END DO 
+c
+c
+C Traitement de la rugosite
+c
+      PRINT*, 'Traitement de la rugosite'
+      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -116,5 +316,5 @@
       ENDIF
 
-      ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
+      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -125,10 +325,10 @@
         print *, NF_STRERROR(ierr)
         STOP
-      ENDIF
+      ENDIF 
       ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
         STOP
-      ENDIF
+      ENDIF 
       print*,'variable ', namedim, 'dimension ', imdep
       ierr = NF_INQ_VARID(ncid,namedim,dimid)
@@ -136,15 +336,19 @@
         print *, NF_STRERROR(ierr)
         STOP
-      ENDIF
-      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_msk)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
       ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
         STOP
-      ENDIF
+      ENDIF 
       print*,'variable ', namedim, 'dimension ', jmdep
       ierr = NF_INQ_VARID(ncid,namedim,dimid)
@@ -152,80 +356,10 @@
         print *, NF_STRERROR(ierr)
         STOP
-      ENDIF
-      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_msk)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF
-      ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF
-
-c
-      CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk,champ_msk,
-     .             iim, jjp1, rlonv, rlatu, champint)
-      CALL gr_int_dyn(champint, masque, iim, jjp1)
-      DO i = 1, iim
-         masque(i,1) = FLOAT(NINT(masque(i,1)))
-         masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
-      ENDDO
-      DO i = 1, iim
-      DO j = 1, jjp1
-         mask(i,j) = champint(i,j)
-      ENDDO
-      ENDDO
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
-      ierr = NF_CLOSE(ncid)
-c
-c
-C Traitement de la rugosite
-c
-      PRINT*, 'Traitement de la rugosite'
-      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF
-
-      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF
-      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
-      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
-      print*,'variable ', namedim, 'dimension ', imdep
-      ierr = NF_INQ_VARID(ncid,namedim,dimid)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
-      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
-      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
-      print*,'variable ', namedim, 'dimension ', jmdep
-      ierr = NF_INQ_VARID(ncid,namedim,dimid)
-      if (ierr.ne.0) then
-        print *, NF_STRERROR(ierr)
-        STOP
-      ENDIF 
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -243,5 +377,9 @@
         STOP
       ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -260,5 +398,9 @@
          PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
          print*,dimfirst,dimlast
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
          ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
          if (ierr.ne.0) then
            print *, NF_STRERROR(ierr)
@@ -274,4 +416,5 @@
          ENDDO
       ENDDO
+c      write(70,*)champtime
 c
       DO l = 1, lmdep
@@ -343,5 +486,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -359,5 +506,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -375,5 +526,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -391,5 +546,9 @@
 c
          PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
          ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
          if (ierr.ne.0) then
            print *, NF_STRERROR(ierr)
@@ -432,17 +591,107 @@
       ENDDO
 c
+c      WRITE(*,*) 'phy_nat'
+c     WRITE(*,'(72f4.1)') phy_nat0(1:klon)
+c
       DO k = 1, 360
-         CALL gr_dyn_fi(1, iip1, jjp1, klon,
-     .                  champan(1,1,k), phy_ice(1,k))
-         DO i = 1, klon
+        CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .      champan(1,1,k), phy_ice)
+        IF ( newlmt) THEN
+
+CPB  en attendant de mettre fraction de terre
+c
+          WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1.
+          WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0.
+c 
+          IF (fracterre ) THEN
+c            WRITE(*,*) 'passe dans cas fracterre' 
+            pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter)
+            pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic)
+            pctsrf_t(1:klon,is_sic,k) =   phy_ice(1:klon) 
+     $            - pctsrf_t(1:klon,is_lic,k)
+c§§ Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP
+            WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0)
+                pctsrf_t(1:klon,is_sic,k) = 0.
+            END WHERE 
+            WHERE( 1. - zmasq(1:klon) .LT. EPSFRA)
+                pctsrf_t(1:klon,is_sic,k) = 0.
+                pctsrf_t(1:klon,is_oce,k) = 0.
+            END WHERE
+            DO i = 1, klon
+c$$              pctsrf_t(i,is_sic,k) = (1. - pctsrf_t(i,is_lic,k) -
+c$$     .                               pctsrf_t(i,is_ter,k)) * phy_ice(i)
+c$$              pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_lic,k) -
+c$$     .                      pctsrf_t(i,is_ter,k) - pctsrf_t(i,is_sic,k)
+              IF ( 1. - zmasq(i) .GT. EPSFRA) THEN 
+                  IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN
+                      pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                      pctsrf_t(i,is_oce,k) = 0.
+                  ELSE 
+                      pctsrf_t(i,is_oce,k) = 1 - zmasq(i) 
+     $                    - pctsrf_t(i,is_sic,k)
+                      IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN
+                          pctsrf_t(i,is_oce,k) = 0.
+                          pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                      ENDIF 
+                  ENDIF
+              ENDIF  
+              if (pctsrf_t(i,is_oce,k) .lt. 0.) then
+                  WRITE(*,*) 'pb sous maille au point : i,k '
+     $                , i,k,pctsrf_t(:,is_oce,k)
+              ENDIF
+              IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + 
+     $            pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k)  - 1.) 
+     $            .GT. EPSFRA) THEN 
+                  WRITE(*,*) 'physiq : pb sous surface au point ', i, 
+     $                pctsrf_t(i, 1 : nbsrf,k), phy_ice(i)
+              ENDIF 
+            END DO
+        ELSE 
+            DO i = 1, klon
+              pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter)
+              IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN
+                pctsrf_t(i,is_sic,k) = 0.
+                pctsrf_t(i,is_oce,k) = 0.                  
+                IF(phy_ice(i) .GE. 1.e-5) THEN
+                  pctsrf_t(i,is_lic,k) = phy_ice(i)
+                  pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) 
+     .                                   - pctsrf_t(i,is_lic,k)
+                ELSE
+                  pctsrf_t(i,is_lic,k) = 0.
+                ENDIF 
+              ELSE
+                pctsrf_t(i,is_lic,k) = 0. 
+                IF(phy_ice(i) .GE. 1.e-5) THEN 
+                  pctsrf_t(i,is_ter,k) = 0.
+                  pctsrf_t(i,is_sic,k) = phy_ice(i)
+                  pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k)
+                ELSE
+                  pctsrf_t(i,is_sic,k) = 0.
+                  pctsrf_t(i,is_oce,k) = 1.                      
+                ENDIF 
+              ENDIF
+              verif = pctsrf_t(i,is_ter,k) +
+     .                pctsrf_t(i,is_oce,k) + 
+     .                pctsrf_t(i,is_sic,k) +
+     .                pctsrf_t(i,is_lic,k)
+              IF ( verif .LT. 1. - 1.e-5 .OR. 
+     $             verif .GT. 1 + 1.e-5) THEN  
+                WRITE(*,*) 'pb sous maille au point : i,k,verif '
+     $                    , i,k,verif
+              ENDIF 
+            END DO
+          ENDIF 
+        ELSE  
+          DO i = 1, klon
             phy_nat(i,k) = phy_nat0(i)
-            IF ( (phy_ice(i,k) - 0.5).GE.1.e-5 ) THEN
-               IF (NINT(phy_nat0(i)).EQ.0) THEN
-                  phy_nat(i,k) = 3.0
-               ELSE
-                  phy_nat(i,k) = 2.0
-               ENDIF
+            IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN
+              IF (NINT(phy_nat0(i)).EQ.0) THEN
+                phy_nat(i,k) = 3.0
+              ELSE
+                phy_nat(i,k) = 2.0
+              ENDIF
             ENDIF
-         ENDDO
+          END DO
+        ENDIF 
       ENDDO
 c
@@ -480,5 +729,10 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+#endif
+
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -496,5 +750,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -512,5 +770,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -528,5 +790,9 @@
 c
          PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
          ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
          if (ierr.ne.0) then
            print *, NF_STRERROR(ierr)
@@ -574,4 +840,5 @@
       ENDDO
 c
+      WHERE(phy_sst .LT. 271.35) phy_sst = 271.35
       ierr = NF_CLOSE(ncid)
 c
@@ -606,5 +873,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -622,5 +893,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -638,5 +913,9 @@
         STOP
       ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
       ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
       if (ierr.ne.0) then
         print *, NF_STRERROR(ierr)
@@ -654,5 +933,9 @@
 c
          PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
          ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
          if (ierr.ne.0) then
            print *, NF_STRERROR(ierr)
@@ -721,25 +1004,40 @@
       dims(2) = ntim
 c
-ccc      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
       ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
       ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
      .                        "Jour dans l annee")
-ccc      ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
-      ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
-      ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
+      IF (newlmt) THEN
+c
+          ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+          ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14,
+     .                        "Fraction ocean")
+c
+          ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+          ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21,
+     .                        "Fraction glace de mer")
+c
+          ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+          ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14,
+     .                        "Fraction terre")
+c
+          ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+          ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17,
+     .                        "Fraction land ice")
+c
+      ELSE 
+          ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+          ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
      .                        "Nature du sol (0,1,2,3)")
-ccc      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+      ENDIF 
+C 
       ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
       ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
      .                        "Temperature superficielle de la mer")
-ccc      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
       ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
       ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
      .                        "Reference flux de chaleur au sol")
-ccc      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
       ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
       ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
      .                        "Albedo a la surface")
-ccc      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
       ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
       ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
@@ -757,5 +1055,19 @@
 #ifdef NC_DOUBLE
       ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
-      ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais,phy_nat(1,k))
+c
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+c
       ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
       ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
@@ -764,5 +1076,17 @@
 #else
       ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
-      ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais,phy_nat(1,k))
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
       ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
       ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
@@ -777,2 +1101,3 @@
       STOP
       END
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/defrun_new.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/defrun_new.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/defrun_new.F	(revision 300)
@@ -1,2 +1,5 @@
+c
+c $Header$
+c
       SUBROUTINE defrun_new( tapedef, etatinit, clesphy0 )
 c
@@ -36,5 +39,5 @@
       INTEGER   tapeout
       REAL clonn,clatt,grossismxx,grossismyy
-      REAL dzoomxx,dzoomyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy
       LOGICAL  fxyhypbb, ysinuss
       INTEGER i
@@ -75,5 +78,5 @@
 c-----------------------------------------------------------------------
 
-      OPEN( tapedef,file ='run.def',status='old',form='formatted')
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
 
 
@@ -258,9 +261,8 @@
       WRITE(tapeout,*)    clonn
       IF( ABS(clon - clonn).GE. 0.001 )  THEN
-        PRINT *,' La valeur de clon passee par run.def est differente de 
-     *  celle lue sur le fichier  start '
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
         STOP
       ENDIF
-c
 c
       READ (tapedef,9001) ch1,ch4
@@ -270,6 +272,6 @@
 
       IF( ABS(clat - clatt).GE. 0.001 )  THEN
-        PRINT *,' La valeur de clat passee par run.def est differente de 
-     *  celle lue sur le fichier  start '
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
         STOP
       ENDIF
@@ -281,6 +283,6 @@
 
       IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
-        PRINT *,' La valeur de grossismx passee par run.def est differente  
-     *  de celle lue sur le fichier  start '
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
         STOP
       ENDIF
@@ -292,11 +294,11 @@
 
       IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
-        PRINT *,' La valeur de grossismy passee par run.def est differen
-     * te de celle lue sur le fichier  start '
+       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
-        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
          STOP
       ELSE
@@ -306,5 +308,5 @@
 
       IF( grossismy.LT.1. )  THEN
-        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
          STOP
       ELSE
@@ -312,5 +314,4 @@
       ENDIF
 
-      PRINT *,' alphax alphay defrun ',alphax,alphay
 c
 c    alphax et alphay sont les anciennes formulat. des grossissements
@@ -324,14 +325,14 @@
       IF( .NOT.fxyhypb )  THEN
            IF( fxyhypbb )     THEN
-              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
-              PRINT *,' *** fxyhypb lu sur le fichier start est F ',
-     *       'alors  qu il est  T  sur  run.def  ***'
+            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
-              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
-              PRINT *,' ***  fxyhypb lu sur le fichier start est T ',
-     *        'alors  qu il est  F  sur  run.def  ****  '
+            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
@@ -343,12 +344,4 @@
       WRITE(tapeout,*)    dzoomxx
 
-      IF( fxyhypb )  THEN
-       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
-        PRINT *,' La valeur de dzoomx passee par run.def est differente 
-     *  de celle lue sur le fichier  start '
-        STOP
-       ENDIF
-      ENDIF
-
       READ (tapedef,9001) ch1,ch4
       READ (tapedef,*)    dzoomyy
@@ -356,10 +349,40 @@
       WRITE(tapeout,*)    dzoomyy
 
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
       IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
        IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
-        PRINT *,' La valeur de dzoomy passee par run.def est differente 
-     * de celle lue sur le fichier  start '
-        STOP
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
        ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
       ENDIF
       
@@ -374,14 +397,14 @@
         IF( .NOT.ysinus )  THEN
            IF( ysinuss )     THEN
-              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
-              PRINT *,' *** ysinus lu sur le fichier start est F ',
-     *       'alors  qu il est  T  sur  run.def  ***'
+              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
-              PRINT *,' ********  PBS DANS  DEFRUN  ******** '
-              PRINT *,' ***  ysinus lu sur le fichier start est T ',
-     *        'alors  qu il est  F  sur  run.def  ****  '
+              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
@@ -389,5 +412,8 @@
       ENDIF
 c
-      close(tapedef)
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
       RETURN
 c   ...............................................
@@ -416,5 +442,5 @@
 
       IF( grossismx.LT.1. )  THEN
-        PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
          STOP
       ELSE
@@ -423,5 +449,5 @@
 
       IF( grossismy.LT.1. )  THEN
-        PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
          STOP
       ELSE
@@ -429,6 +455,4 @@
       ENDIF
 
-      PRINT *,' alphax alphay defrun ',alphax,alphay
-
 c
       READ (tapedef,9001) ch1,ch4
@@ -446,5 +470,15 @@
       WRITE(tapeout,9001) ch1,'dzoomy'
       WRITE(tapeout,*)    dzoomy
-c
+
+      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
@@ -452,9 +486,11 @@
       WRITE(tapeout,*)    ysinus
        
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
 c
 9000  FORMAT(3(/,a72))
 9001  FORMAT(/,a72,/,a12)
 cc
-      close(tapedef)
+      CLOSE(tapedef)
+
       RETURN
       END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/dynetat0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dynetat0.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/dynetat0.F	(revision 300)
@@ -1,2 +1,5 @@
+c
+c $Header$
+c
       SUBROUTINE dynetat0(fichnom,nq,vcov,ucov,
      .                    teta,q,masse,ps,phis,time)
@@ -105,4 +108,6 @@
         dzoomx   = tab_cntrl(25)
         dzoomy   = tab_cntrl(26)
+        taux     = tab_cntrl(28)
+        tauy     = tab_cntrl(29)
       ELSE
         fxyhypb = . FALSE .
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/dynredem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dynredem.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/dynredem.F	(revision 300)
@@ -1,3 +1,6 @@
+c $Header$
+c
       SUBROUTINE dynredem0(fichnom,idayref,anneeref,phis,nq)
+      USE IOIPSL
       IMPLICIT NONE
 c=======================================================================
@@ -44,6 +47,16 @@
       INTEGER idim_tim
       INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
 c-----------------------------------------------------------------------
       modname='dynredem'
+
+      call ymds2ju(anneeref,1,idayref,0.0, zjulian)
+      call ju2ymds(zjulian, yyears0,mmois0,jjour0,hours)
+        
 
       DO l=1,length
@@ -81,4 +94,7 @@
        tab_cntrl(25) = dzoomx
        tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = taux
+       tab_cntrl(29) = tauy
       ELSE
        tab_cntrl(24) = 0.
@@ -86,5 +102,7 @@
        tab_cntrl(26) = dzoomy
        tab_cntrl(27) = 0.
-       IF( ysinus )  tab_cntrl(27) = 1. 
+       tab_cntrl(28) = 0.
+       tab_cntrl(29) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1.
       ENDIF
 c
@@ -121,9 +139,5 @@
 c
       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")
@@ -136,9 +150,5 @@
 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")
@@ -151,9 +161,5 @@
 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")
@@ -166,9 +172,5 @@
 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")
@@ -181,9 +183,5 @@
 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")
@@ -196,9 +194,5 @@
 c
       ierr = NF_REDEF (nid)
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
      .                       "Numero naturel des couches s")
@@ -211,9 +205,5 @@
 c
       ierr = NF_REDEF (nid)
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
      .                       "Numero naturel des couches sigma")
@@ -226,9 +216,5 @@
 c
       ierr = NF_REDEF (nid)
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
      .                       "Coefficient A pour hybride")
@@ -241,9 +227,5 @@
 c
       ierr = NF_REDEF (nid)
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
      .                       "Coefficient B pour hybride")
@@ -256,9 +238,5 @@
 c
       ierr = NF_REDEF (nid)
-#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
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
@@ -273,9 +251,5 @@
       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")
@@ -290,9 +264,5 @@
       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")
@@ -309,9 +279,5 @@
       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")
@@ -328,9 +294,5 @@
       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")
@@ -346,11 +308,12 @@
       ierr = NF_REDEF (nid) ! entrer dans le mode de definition
 c
-#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
       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
@@ -358,9 +321,5 @@
       dims4(3) = idim_s
       dims4(4) = idim_tim
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
      .                       "Vitesse U")
@@ -370,9 +329,5 @@
       dims4(3) = idim_s
       dims4(4) = idim_tim
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
      .                       "Vitesse V")
@@ -382,9 +337,5 @@
       dims4(3) = idim_s
       dims4(4) = idim_tim
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
      .                       "Temperature")
@@ -402,9 +353,5 @@
          str3(1:1)='q'
          WRITE(str3(2:3),'(i2.2)') iq
-#ifdef NC_DOUBLE
-         ierr = NF_DEF_VAR (nid,str3,NF_DOUBLE,4,dims4,nvarid)
-#else
          ierr = NF_DEF_VAR (nid,str3,NF_FLOAT,4,dims4,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
      .                       "Traceurs "//str3)
@@ -417,9 +364,5 @@
       dims4(3) = idim_s
       dims4(4) = idim_tim
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
      .                       "C est quoi ?")
@@ -428,9 +371,5 @@
       dims3(2) = idim_rlatu
       dims3(3) = idim_tim
-#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
       ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
      .                       "Pression au sol")
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/etat0_netcdf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/etat0_netcdf.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/etat0_netcdf.F	(revision 300)
@@ -2,36 +2,59 @@
     
       USE startvar
-      USE IOIPSL
+      USE ioipsl
       !
       IMPLICIT NONE
       !
+#include "netcdf.inc"
 #include "dimensions.h"
 #include "paramet.h"
       !
       !
-      INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, 
-     .KLON=KFDIA-KIDIA+1,KLEV=llm
+c      INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, 
+c     .KLON=KFDIA-KIDIA+1,KLEV=llm
       !
 #include "comgeom2.h"
 #include "comvert.h"
 #include "comconst.h"
+#include "indicesol.h"
+#include "dimphy.h"
+#include "dimsoil.h"
       !
       REAL :: latfi(klon), lonfi(klon)
       REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1),
      . psol(iip1, jjp1), phis(iip1, jjp1)
-      REAL :: p3d(iip1, jjp1, llmp1)
-      REAL :: uvent(iip1, jjp1, llmp1)
-      REAL :: vvent(iip1, jjm, llmp1)
-      REAL :: t3d(iip1, jjp1, llmp1), tpot(iip1, jjp1, llmp1)
-      REAL :: q3d(iip1, jjp1, llmp1,nqmx), qsat(iip1, jjp1, llmp1)
-      REAL :: tsol(klon), qsol(klon), sn(klon), radsol(klon)
-      REAL :: deltat(klon), rugmer(klon), agesno(klon), zmea(klon)
-      REAL :: zstd(klon), zsig(klon), zgam(klon), zthe(klon)
-      REAL :: zpic(klon), zval(klon), rugsrel(klon)
-      REAL :: qd(iip1, jjp1, llmp1)
-      !
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: uvent(iip1, jjp1, llm)
+      REAL :: vvent(iip1, jjm, llm)
+      REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm)
+      REAL :: q3d(iip1, jjp1, llm,nqmx), qsat(iip1, jjp1, llm)
+      REAL :: tsol(klon), qsol(klon), sn(klon)
+      REAL :: tsolsrf(klon,nbsrf), qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) 
+      REAL :: albe(klon,nbsrf), evap(klon,nbsrf)
+      REAL :: tsoil(klon,nsoilmx,nbsrf) 
+      REAL :: radsol(klon),rain_fall(klon), snow_fall(klon)
+      REAL :: solsw(klon), sollw(klon)
+      REAL :: deltat(klon), frugs(klon,nbsrf), agesno(klon),rugmer(klon)
+      REAL :: zmea(iip1*jjp1), zstd(iip1*jjp1)
+      REAL :: zsig(iip1*jjp1), zgam(iip1*jjp1), zthe(iip1*jjp1)
+      REAL :: zpic(iip1*jjp1), zval(iip1*jjp1), rugsrel(iip1*jjp1)
+      REAL :: qd(iip1, jjp1, llm)
+      REAL :: pctsrf(klon, nbsrf)
+      REAL :: t_ancien(klon,klev), q_ancien(klon,klev)      !
+      ! declarations pour lecture glace de mer
+      REAL :: rugv(klon)
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+      REAL :: champint(iim, jjp1)
+      !
+
       CHARACTER*80 :: varname
       !
-      INTEGER :: i,j, ig, l
+      INTEGER :: i,j, ig, l, ji
       REAL :: xpi
       !
@@ -54,5 +77,5 @@
       PARAMETER      ( longcles  = 20 )
       REAL :: clesphy0 ( longcles       )
-      REAL :: p(iip1,jjp1,llmp1)
+      REAL :: p(iip1,jjp1,llm)
       INTEGER :: itau, iday
       REAL :: masse(iip1,jjp1,llm)
@@ -62,8 +85,20 @@
       REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
       REAL :: w(ip1jmp1,llm)
-      REAL ::phystep,radpas,co2_ppm,solaire
+      REAL ::phystep,co2_ppm,solaire
+      INTEGER :: radpas
 
       CHARACTER*80 :: visu_file
       INTEGER :: visuid
+
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+      integer :: isst(klon-2)
+
       !
       !   Constantes 
@@ -135,5 +170,5 @@
       varname = 'masque'
       ! This line needs to be replaced by a call to restget to get the values in the restart file
-      rugo(:,:) = 0.0
+      masque(:,:) = 0.0
        CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0)
       !
@@ -142,4 +177,25 @@
       !
       !
+
+
+C
+C on initialise les sous surfaces
+C
+      pctsrf=0.
+      !cree le masque a partir du fichier relief
+      varname = 'zmasq'
+      zmasq(:) = 0.
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmasq,0.0)
+      WHERE (zmasq(1 : klon) .LT. EPSFRA)
+          zmasq(1 : klon) = 0.
+      END WHERE 
+      WHERE (1. - zmasq(1 : klon) .LT. EPSFRA)
+          zmasq(1 : klon) = 1.
+      END WHERE 
+      WRITE(*,*)zmasq
+
+
+
+
       varname = 'psol'
       psol(:,:) = 0.0
@@ -173,5 +229,6 @@
       phis(:,:) = 0.0
       CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0)
-      phis = phis * 9.81
+      write(*,*) 'Phis = '
+      write(*,*)phis
       !
       varname = 'u'
@@ -215,5 +272,7 @@
       !
       varname = 'q'
+      q3d(:,:,:,:) = 0.0
       qd(:,:,:) = 0.0
+      q3d(:,:,:,:) = 0.0
       WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
      .                           maxval(qsat(:,:,:))
@@ -225,5 +284,5 @@
       ! This line needs to be replaced by a call to restget to get the values in the restart file
       tsol(:) = 0.0
-      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0)
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol,0.0)
       !
       WRITE(*,*) 'TSOL construit :'
@@ -232,9 +291,9 @@
       varname = 'qsol'
       qsol(:) = 0.0
-      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0)
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol,0.0)
       !
       varname = 'snow'
       sn(:) = 0.0
-      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0)
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn,0.0)
       !
       varname = 'rads'
@@ -276,4 +335,158 @@
       CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0)
       rugsrel(:) = 0.0
+
+C
+C En cas de simulation couplee, lecture du masque ocean issu du modele ocean
+C utilise pour calculer les poids et pour assurer l'adequation entre les
+C fractions d'ocean vu par l'atmosphere et l'ocean
+C
+
+      write(*,*)'Essai de lecture masque ocean'
+      iret = nf_open("o2a.nc", NF_NOWRITE, nid_o2a)
+      if (iret .ne. 0) then
+        write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve'
+        write(*,*)'Run force'
+      else
+        couple = .true.
+        iret = nf_close(nid_o2a)
+        call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp
+     $    , nid_o2a)
+        if (iml_omask /= iim .or. jml_omask /= jjp1) then
+          write(*,*)'Dimensions non compatibles pour masque ocean'
+          write(*,*)'iim = ',iim,' iml_omask = ',iml_omask
+          write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask
+          stop
+        endif
+        ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(dlon_omask(iml_omask), stat=iret)
+        ALLOCATE(dlat_omask(jml_omask), stat=iret)
+        ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret)
+        ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret)
+        CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp
+     $    , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid)
+        CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, 
+     $      ttm_tmp, 1, 1, ocetmp)
+        CALL flinclo(fid)
+        dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1)
+        dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask)
+        ocemask = ocetmp
+        if (dlat_omask(1) < dlat_omask(jml_omask)) then
+          do j = 1, jml_omask
+            ocemask(:,j) = ocetmp(:,jml_omask-j+1)
+          enddo
+        endif 
+C
+C passage masque ocean a la grille physique
+C
+        ocemask_fi(1) = ocemask(1,1)
+        do j = 2, jjm
+          do i = 1, iim
+            ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j)
+          enddo
+        enddo
+        ocemask_fi(klon) = ocemask(1,jjp1)
+        zmasq = 1. - ocemask_fi
+        isst = 0
+        where (ocemask_fi(2:klon-1) >0.) isst = 1
+        write(45,'(72i1)')isst
+      endif
+
+
+C
+C lecture du fichier glace de terre pour fixer la fraction de terre 
+C et de glace de terre
+C
+      CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp
+     $    , fid)
+      ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(dlon_lic(iml_lic), stat=iret)
+      ALLOCATE(dlat_lic(jml_lic), stat=iret)
+      ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret)
+      CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp
+     $    , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid)
+      CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp
+     $    , 1, 1, fraclic)
+      CALL flinclo(fid)
+C
+C interpolation sur la grille T du modele
+C
+      WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', 
+     $    iml_lic, jml_lic
+c
+C sil les coordonnees sont en degres, on les transforme
+C
+      IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) )  THEN
+          lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180.
+      ENDIF 
+      IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN 
+          lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180.
+      ENDIF 
+
+      dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1)
+      dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) 
+C
+      CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic
+     $    ,iim, jjp1,
+     $    rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1))
+c$$$      flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1)
+      flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1)
+C
+C passage sur la grille physique
+C
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp,
+     $    pctsrf(1:klon, is_lic))
+C adequation avec le maque terre/mer
+c      zmasq(157) = 0.
+      WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) 
+          pctsrf(1 : klon, is_lic) = 0. 
+      END WHERE
+      WHERE (zmasq( 1 : klon) .LT. EPSFRA) 
+          pctsrf(1 : klon, is_lic) = 0.
+      END WHERE 
+      pctsrf(1 : klon, is_ter) = zmasq(1 : klon)
+      DO ji = 1, klon
+        IF (zmasq(ji) .GT. EPSFRA) THEN 
+            IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN
+                pctsrf(ji, is_lic) = zmasq(ji)
+                pctsrf(ji, is_ter) = 0.
+            ELSE 
+                pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic)
+                IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN
+                    pctsrf(ji,is_ter) = 0.
+                    pctsrf(ji, is_lic) = zmasq(ji)
+                ENDIF 
+            ENDIF 
+        ENDIF 
+      END DO 
+C
+C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0)
+C
+      pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon))
+
+
+      WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA)
+          pctsrf(1 : klon, is_oce) = 0.
+      END WHERE 
+
+      if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon)
+
+      isst = 0
+      where (pctsrf(2:klon-1,is_oce) >0.) isst = 1
+      write(46,'(72i1)')isst
+C
+C verif que somme des sous surface = 1
+C
+      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+     $    .GT. EPSFRA)
+      IF (ji .NE. 0) THEN
+          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+      ENDIF 
+
+
+
+
+
 C Calcul intermediaire
 c 
@@ -283,18 +496,16 @@
       print *,' ALPHAX ',alphax
 
-      IF( alphax.NE.0. )   THEN
-       DO  l = 1, llm
-         DO  i    = 1, iim
+      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
+        ENDDO
           xpn      = SUM(xppn)/apoln
           xps      = SUM(xpps)/apols
-         DO i   = 1, iip1
+        DO i   = 1, iip1
           masse(   i   ,   1     ,  l )   = xpn
           masse(   i   ,   jjp1  ,  l )   = xps
-         ENDDO
-       ENDDO
-      ENDIF
+        ENDDO
+      ENDDO
       q3d(iip1,:,:,:) = q3d(1,:,:,:)
       phis(iip1,:) = phis(1,:)
@@ -333,10 +544,55 @@
       solaire   = 1370.0
 
-      call physdem(lonfi, latfi, phystep,radpas,co2_ppm,
-     .                   solaire,tsol, qsol,
-     .                   sn, radsol, deltat, rugmer,
-     .                   agesno, zmea, zstd, zsig,
-     .                   zgam, zthe, zpic, zval,
-     .                   rugsrel)
+c      call physdem(lonfi, latfi, phystep,radpas,co2_ppm,
+c     .                   solaire,tsol, qsol,
+c     .                   sn, radsol, deltat, rugmer,
+c     .                   agesno, zmea, zstd, zsig,
+c     .                   zgam, zthe, zpic, zval,
+c     .                   rugsrel)
+
+c
+c Initialisation 
+c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs
+c
+      tsolsrf(:,is_ter) = tsol
+      tsolsrf(:,is_lic) = tsol
+      tsolsrf(:,is_oce) = tsol
+      tsolsrf(:,is_sic) = tsol
+      snsrf(:,is_ter) = sn
+      snsrf(:,is_lic) = sn
+      snsrf(:,is_oce) = sn
+      snsrf(:,is_sic) = sn
+      albe(:,is_ter) = 0.08
+      albe(:,is_lic) = 0.6
+      albe(:,is_oce) = 0.5
+      albe(:,is_sic) = 0.6
+      evap(:,:) = 0.
+      qsolsrf(:,is_ter) = 150
+      qsolsrf(:,is_lic) = 150
+      qsolsrf(:,is_oce) = 150.
+      qsolsrf(:,is_sic) = 150.
+      do i = 1, nbsrf
+        do j = 1, nsoilmx
+          tsoil(:,j,i) = tsol
+        enddo
+      enddo
+      rain_fall = 0.; snow_fall = 0.
+      solsw = 165.
+      sollw = -53.
+      t_ancien = 273.15
+      q_ancien = 0.
+      agesno = 0.
+      deltat = 0.
+      frugs(1:klon,is_oce) = rugmer(1:klon)
+      frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0)
+      frugs(1:klon,is_sic) = 0.001
+
+      call physdem("startphy.nc",phystep,radpas, co2_ppm, solaire,
+     $    latfi, lonfi, pctsrf, tsolsrf, tsoil, deltat, qsolsrf, snsrf, 
+     $    albe, evap, rain_fall, snow_fall, solsw, sollw, 
+     $    radsol, frugs,  agesno, 
+     $    zmea, zstd, zsig, zgam, zthe, zpic, zval, rugsrel, 
+     $    t_ancien, q_ancien)
 
 C     Sortie Visu pour les champs dynamiques
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/exner_hyb.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/exner_hyb.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/exner_hyb.F	(revision 300)
@@ -53,20 +53,18 @@
 c
       DO   ij  = 1, ngrid
-       pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
       ENDDO
 
-      IF( alphax.NE.0. )   THEN
-        DO  ij   = 1, iim
-         ppn(ij) = aire(   ij   ) * pks(  ij     )
-         pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
-        ENDDO
-         xpn      = SSUM(iim,ppn,1) /apoln
-         xps      = SSUM(iim,pps,1) /apols
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
 
-        DO ij   = 1, iip1
-         pks(   ij     )  =  xpn
-         pks( ij+ip1jm )  =  xps
-        ENDDO
-      ENDIF
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
 c
 c
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fluxstoke.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fluxstoke.F	(revision 3)
+++ 	(revision )
@@ -1,149 +1,0 @@
-      SUBROUTINE fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
-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"
-
-
-      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)
-
-
-      INTEGER iadvtr 
-      INTEGER ij,l,irec,i,j
- 
-      SAVE iadvtr, massem,pbaruc,pbarvc,irec
-      SAVE phic,tetac
-      logical first
-      save first
-      data first/.true./
-      DATA iadvtr/0/
-
-      if(first) then
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
-#endif
-         open(47,file='fluxmass',form='unformatted',
-     s        access='direct',recl=4*(6*ijp1llm))
-         irec=1
-         first=.false.
-
-         open(77,file='fluxmass.ctl',status='unknown',form='formatted')
-
-      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)/float(istdyn)
-            tetac(ij,l) = tetac(ij,l)/float(istdyn)
-            phic(ij,l) = phic(ij,l)/float(istdyn)
-         ENDDO
-         DO ij = 1,ip1jm
-            pbarvc(ij,l) = pbarvc(ij,l)/float(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
-
-         irec=irec+1
-         write(47,rec=1) float(irec),dtvr,float(istdyn),
-     s    float(iim),float(jjm),float(llm),rlonu,rlonv,rlatu,rlatv
-     s    ,aire,phis
-         write(47,rec=irec) massem,pbarug,pbarvst,wg,tetac,phic
-
-c   on reinitialise a zero les flux de masse cumules.
-
-      write(77,'(a4,2x,a40)')
-     &       'DSET ','^fluxmass'
-
-      write(77,'(a12)') 'UNDEF 1.0E30'
-      write(77,'(a5,1x,a40)') 'TITLE ','Titre a voir'
-      call formcoord(77,iip1,rlonv,180./pi,.false.,'XDEF')
-      call formcoord(77,jjp1,rlatu,180./pi,.true.,'YDEF')
-      call formcoord(77,llm,presnivs,1.,.false.,'ZDEF')
-      write(77,'(a4,i10,a30)')
-     &       'TDEF ',irec,' LINEAR 02JAN1987 1DY '
-      write(77,'(a4,2x,i5)') 'VARS',6
-      write(77,1000) 'masse',llm,99,'masse    '
-      write(77,1000) 'pbaru',llm,99,'pbaru    '
-      write(77,1000) 'pbarv',llm,99,'pbarv    '
-      write(77,1000) 'w    ',llm,99,'w        '
-      write(77,1000) 'teta ',llm,99,'teta     '
-      write(77,1000) 'phi  ',llm,99,'phi      '
-      write(77,'(a7)') 'ENDVARS'
-
-1000  format(a5,3x,i4,i3,1x,a39)
-
-
-
-      ENDIF ! if iadvtr.EQ.istdyn
-
-      RETURN
-      END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fluxstokenc.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fluxstokenc.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fluxstokenc.F	(revision 300)
@@ -0,0 +1,155 @@
+      SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     . time_step,itau )
+
+       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"
+
+      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 fluxid, fluxvid,fluxdid
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+
+      if(first) then
+
+	CALL initfluxsto( 'fluxstoke',
+     .  time_step,istdyn* time_step,istdyn* time_step,
+     . nqmx, 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)/float(istdyn)
+            tetac(ij,l) = tetac(ij,l)/float(istdyn)
+            phic(ij,l) = phic(ij,l)/float(istdyn)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l)/float(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
+	Print*,'ITAU auqel 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
+
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fxhyp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxhyp.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fxhyp.F	(revision 300)
@@ -1,4 +1,5 @@
        SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,tau ,
-     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025)
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
 
 c      Auteur :  P. Le Van 
@@ -11,9 +12,12 @@
 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 transition ,   normalement  = 1  .
-c
+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 = 50000, nmax2 = 2*nmax )
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
 
 #include "dimensions.h"
@@ -23,63 +27,114 @@
 c
        REAL xzoomdeg,dzoom,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
        REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
      ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
 
-c    ......   arguments  de  sortie  ......
-c
-       REAL xlon(iip1),xprimm(iip1),xuv
-       REAL xtild(0:nmax2)
-       REAL fhyp(0:nmax),ffdx(0:nmax),beta,Xprimt(0:nmax2)
-       REAL Xf(0:nmax2),xxpr(0:nmax2)
-       REAL xvrai(iip1),xxprim(iip1) 
-       REAL pi,depi,epsilon,xzoom
+c     .... variables locales  ....
+c
+       REAL*8 xlon(iip1),xprimm(iip1),xuv
+       REAL*8 xtild(0:nmax2)
+       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
+       REAL*8 xvrai(iip1),xxprim(iip1) 
+       REAL*8 pi,depi,epsilon,xzoom,fa,fb
+       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
        INTEGER i,it,ik,iter,ii,idif
-       REAL xi,xo1,xint,xmoy,xlon2,fxm,Xprimin
-       REAL champmin,champmax
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax
        INTEGER is2
        SAVE is2
-       REAL dlon1(iip1),dlon2(iip1),dlon3(iip1)
+
+       REAL*8 heavyside
+       EXTERNAL coefpoly,heavyside
 
        pi       = 2. * ASIN(1.)
        depi     = 2. * pi
-       epsilon  = 1.e-6
+       epsilon  = 1.e-3
        xzoom    = xzoomdeg * pi/180. 
 
-
+       IF( dzoom.LT.1.)  THEN
+         dzoom = dzoom * depi
+       ELSEIF( dzoom.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzoom * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
 
        DO i = 0, nmax2 
-         xtild(i) = FLOAT(i) /nmax2
-        IF( xtild(i).EQ. 0.5 )  xtild(i) = xtild(i) + 1.e-6
-       ENDDO
-
-       DO i = 1, nmax
-        fhyp(i) = TANH ( ( xtild(i) - 0.5*(1.- dzoom) )          /
-     ,                 ( tau * xtild(i) * ( 0.5 -xtild(i))) )
-       ENDDO
-
-        fhyp(   0  ) = - 1.
-        fhyp( nmax ) =   1.
+        xtild(i) = - pi + FLOAT(i) * depi /nmax2
+       ENDDO
+
+       DO i = 0, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+
+       if ( xtild(i) .ne. 0. .and. xtild(i) .ne. pi) then
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         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  ....
-c
-       ffdx( 0 ) = 0.
-
-       DO i = 1, nmax
-        xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
-        fxm     = TANH ( ( xmoy - 0.5 * ( 1. - dzoom ) )    /
-     ,                 ( tau * xmoy * ( 0.5 -xmoy)) )
-        ffdx(i) = ffdx(i-1) + fxm * ( xtild(i) - xtild(i-1) )
-       ENDDO
-
-        beta  = ( grossism * ffdx(nmax) - 0.5 ) / ( ffdx(nmax) - 0.5 )
+c   ............................
+
+       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
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fhyp(i) =  1.
+       IF ( xmoy.EQ. pi )  fhyp(i) = -1.
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
 c
 c   .....  calcul  de  Xprimt   .....
 c
        
-       DO i = 0, nmax
+       DO i = nmax, nmax2
         Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
        ENDDO
 c   
-       DO i = 0, nmax
+       DO i =  nmax+1, nmax2
         Xprimt( nmax2 - i ) = Xprimt( i )
        ENDDO
@@ -88,14 +143,28 @@
 c   .....  Calcul  de  Xf     ........
 
-        Xf(0) = 0.
-       DO i = 1, nmax
-        xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
-        fxm     = TANH ( ( xmoy - 0.5 * ( 1. - dzoom ) )    /
-     ,                 ( tau * xmoy * ( 0.5 -xmoy)) )
-        xxpr(i)    = beta + ( grossism - beta ) * fxm
-       ENDDO
-
-       DO i = 1,nmax
-         xxpr(nmax2-i+1) = xxpr(i)
+       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
 
@@ -103,10 +172,4 @@
          Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
         ENDDO
-        do i=1,nmax2
-        xf(i)=xf(i)/xf(nmax2)
-        enddo
-
-
-       PRINT *,' XF ',xf(0),xf(nmax),xf(nmax2)
 
 
@@ -117,4 +180,5 @@
 c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
 c
+      WRITE(6,18)
 c
       DO 5000  ik = 1, 4
@@ -130,66 +194,68 @@
        ENDIF
 
+      xo1   = 0.
 
       DO 1500 i = 1, iim
 
-      xlon2 = (  FLOAT(i) + xuv - 0.75) / FLOAT(iim) 
-
-      xo1   = 0.
-      xi    = xlon2
-c
-      DO 500 iter = 1,300
-
+      xlon2 = - pi + (FLOAT(i) + xuv - 0.75) * depi / FLOAT(iim) 
+
+      Xfi    = xlon2
+c
       DO 250 it =  nmax2,0,-1
-      IF( xi.GE.xtild(it))  GO TO 350
+      IF( Xfi.GE.Xf(it))  GO TO 350
 250   CONTINUE
 
       it = 0
-      xi = xtild(it)
 
 350   CONTINUE
-       IF(it.EQ.nmax2)  THEN
-        it       = nmax2 -1
-        xf(it+1) = 1.
-       ENDIF
-c  .................................................................
-c  ....  Interpolation entre  xi(it) et xi(it+1)   pour avoir X(xi)  
-c      .....           et   X'(xi)                             .....
-c  .................................................................
-
-       xint   = ( Xf(it+1)-Xf(it) ) / ( xtild(it+1)-xtild(it) )      * 
-     +                    ( xi-xtild(it) )  +  Xf(it)
-      Xprimin = ( Xprimt(it+1)-Xprimt(it) )/ ( xtild(it+1)-xtild(it) ) *
-     +                    ( xi-xtild(it) )  +  Xprimt(it)
-
-       xi = xi - (xint-xlon2)/Xprimin
-
-      IF( ABS(xi-xo1).LE.epsilon) GO TO 550
-      xo1 = xi
-c
+
+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
-      PRINT *,' ***   PAS DE SOLUTION  ****  ',i,xlon2
-        STOP 4
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
 550   CONTINUE
 
-       xxprim(i)   = depi/( FLOAT(iim) * Xprimin)
-       xvrai(i)    = depi *  (xi - 0.5) + xzoom
-
+       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
 
 1500   CONTINUE
 
        DO i = 1 , iim
-        xlon  (i)   = xvrai(i)
+        xlon(i)     = xvrai(i)
         xprimm(i)   = xxprim(i)
-cc        xxlon(i) = xlon(i)*180./pi
        ENDDO
         
-cc      PRINT *,' XLON avant '
-cc      PRINT 68,(xxlon(i),i=1,iim)
-       
        DO i = 1, iim -1
         IF( xvrai(i+1). LT. xvrai(i) )  THEN
-         PRINT *,' PBS.  avec  rlonu(',i+1,' plus petit que rlonu(',i,
-     ,   ')'
-         STOP
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
         ENDIF
        ENDDO
@@ -205,12 +271,9 @@
        ENDDO
 
-       PRINT *,' LONGITUDES  min max ',champmin,champmax
-
       IF(champmin .GE. - pi .AND. champmax.LE. pi )  THEN
                 GO TO 1600
       ELSE
-        PRINT 18
-        PRINT *,'Reorganisation des longitudes pour avoir entre - pi ',
-     ,  ' et  pi '
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
 c
         IF( xzoom.LE.0.)  THEN
@@ -219,6 +282,6 @@
            IF( xvrai(i).GE. - pi )  GO TO 80
           ENDDO
-            PRINT *, ' PBS. 1 '
-            STOP
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
  80       CONTINUE
           is2 = i
@@ -240,10 +303,9 @@
             IF( xvrai(i).LE. pi )  GO TO 90
            ENDDO
-             PRINT *,' PBS.  2 '
-              STOP
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
  90        CONTINUE
             is2 = i
           ENDIF
-cc           PRINT *,' IS2 ',is2
            idif = iim -is2
            DO ii = 1, is2
@@ -270,84 +332,76 @@
          ENDDO
 
-
          IF( ik.EQ.1 )  THEN
-         PRINT *, ' XLON aux pts. V-0.25   apres ( en  deg. ) '
-         PRINT 18
-         PRINT 68,xvrai
-         PRINT *,' XPRIM '
-         PRINT 68, xprimm
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+ccc          WRITE(6,*) ' XPRIM k ',ik
+ccc          WRITE(6,566)  xprimm
+
            DO i = 1,iim + 1
              rlonm025(i) = xlon( i )
             xprimm025(i) = xprimm(i)
            ENDDO
+
          ELSE IF( ik.EQ.2 )  THEN
-         PRINT 18
-         PRINT *, ' XLON aux pts. V   apres ( en  deg. ) '
-         PRINT 68,xvrai
-         PRINT *,' XPRIM '
-         PRINT 68, xprimm
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+ccc          WRITE(6,*) ' XPRIM k ',ik
+ccc          WRITE(6,566)  xprimm
+
            DO i = 1,iim + 1
              rlonv(i) = xlon( i )
             xprimv(i) = xprimm(i)
            ENDDO
-         ELSE IF( ik.EQ.3 )  THEN
-         PRINT 18
-         PRINT *, ' XLON aux pts. U   apres ( en  deg. ) '
-         PRINT 68,xvrai
-         PRINT *,' XPRIM '
-         PRINT 68, xprimm
+
+         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
+ccc          WRITE(6,*) ' XPRIM ik ',ik
+ccc          WRITE(6,566)  xprimm
+
            DO i = 1,iim + 1
              rlonu(i) = xlon( i )
             xprimu(i) = xprimm(i)
            ENDDO
+
          ELSE IF( ik.EQ.4 )  THEN
-         PRINT 18
-         PRINT *, ' XLON aux pts. V+0.25   apres ( en  deg. ) '
-         PRINT 68,xvrai
-         PRINT *,' XPRIM '
-         PRINT 68, xprimm
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+ccc          WRITE(6,*) ' XPRIM ik ',ik
+ccc          WRITE(6,566)  xprimm
+
            DO i = 1,iim + 1
              rlonp025(i) = xlon( i )
             xprimp025(i) = xprimm(i)
            ENDDO
+
          ENDIF
 
 5000    CONTINUE
 c
-c       ...........  fin  de la boucle  do 5000      ............
-
-c
-        DO i = 1, iim + 1
-         dlon1(i) = rlonm025(i) - rlonv(i)
-         dlon2(i) = rlonm025(i) - rlonp025(i)
-         dlon3(i) = rlonm025(i) - rlonu(i)
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
         ENDDO
-
-        DO i = 1, iim + 1
-         rlonm025(i) = rlonm025(i) + dlon1(i)
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
         ENDDO
-
-        DO i = 1, iim + 1
-         rlonv(i)    = rlonm025(i) - dlon1(i)
-         rlonp025(i) = rlonm025(i) - dlon2(i)
-         rlonu(i)    = rlonm025(i) - dlon3(i)
-        ENDDO
-
-        DO i = 1, iim
-         xprimu   (i) = rlonu(i+1) - rlonu(i)
-         xprimv   (i) = rlonv(i+1) - rlonv(i)
-         xprimm025(i) = rlonm025(i+1) - rlonm025(i)
-         xprimp025(i) = rlonp025(i+1) - rlonp025(i)
-        ENDDO
-         xprimu   (iip1) = xprimu   (1)
-         xprimv   (iip1) = xprimv   (1)
-         xprimm025(iip1) = xprimm025(1)
-         xprimp025(iip1) = xprimp025(1)
-
-
-18       FORMAT(/)
-68       FORMAT(1x,7f9.2)
-
-
-         RETURN
-         END
+         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)
+
+       RETURN
+       END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fxyhyper.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxyhyper.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fxyhyper.F	(revision 300)
@@ -1,4 +1,7 @@
-       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy,deltay  , 
-     ,                      xzoom, grossx, dzoomx,taux,
+c
+c $Header$
+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)
@@ -19,13 +22,9 @@
 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       du zoom  :   tau   , ici  =  1.
+c     c) la raideur de la transition du zoom  :   taux et tauy   
 c
-c     N.B :   le produit ( grossissement * extension )  doit etre <  1.
-c    *******
-c     En plus , il y a un autre parametre , moins important mais quand
-c     meme utile , c'est  deltay , deplacement de la zone du zoom en
-c     latitude   :  Si  on deplace  de 10. degres vers le nord  ( deltay
-c      = 10.  dans inigeom ) .
-c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
 c
 #include "dimensions.h"
@@ -40,5 +39,5 @@
        REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
      , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
-       REAL deltay
+       REAL*8  dxmin, dxmax , dymin, dymax
 
 c   ....   var. locales   .....
@@ -47,30 +46,30 @@
 c
 
-       CALL fyhyp ( yzoom, grossy, dzoomy,tauy, deltay , 
-     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 )
+       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         )
 
 
-       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
-     , xprimv,rlonu,xprimu,rlonp025,xprimp025 )
-
-
-        DO i = 1, iim
+        DO i = 1, iip1
           IF(rlonp025(i).LT.rlonv(i))  THEN
-           PRINT *,' Attention !  rlonp025 < rlonv',i
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
             STOP
           ENDIF
 
           IF(rlonv(i).LT.rlonm025(i))  THEN 
-           PRINT *,' Attention !  rlonm025 > rlonv',i
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
             STOP
           ENDIF
 
           IF(rlonp025(i).GT.rlonu(i))  THEN
-           PRINT *,' Attention !  rlonp025 > rlonu',i
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
             STOP
           ENDIF
         ENDDO
 
-        PRINT *,'  *** TEST DE COHERENCE  OK    POUR   FX **** '
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
 
 c
@@ -78,30 +77,30 @@
 c
        IF(rlatu1(j).LE.rlatu2(j))   THEN
-         PRINT *,' Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
          STOP 13
        ENDIF
 c
        IF(rlatu2(j).LE.rlatu(j+1))  THEN
-        PRINT *,' Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
         STOP 14
        ENDIF
 c
        IF(rlatu(j).LE.rlatu1(j))    THEN
-        PRINT *,' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
         STOP 15
        ENDIF
 c
        IF(rlatv(j).LE.rlatu2(j))    THEN
-        PRINT *,' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
         STOP 16
        ENDIF
 c
        IF(rlatv(j).ge.rlatu1(j))    THEN
-        PRINT *,' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
         STOP 17
        ENDIF
 c
        IF(rlatv(j).ge.rlatu(j))     THEN
-        PRINT *,'Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
         STOP 18
        ENDIF
@@ -109,7 +108,28 @@
        ENDDO
 c
-       PRINT *,'  *** TEST DE COHERENCE  OK    POUR   FY **** '
-
+       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
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fyhyp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fyhyp.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/fyhyp.F	(revision 300)
@@ -1,5 +1,10 @@
-       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzoom,tau,deltay ,  
-     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ) 
-
+c
+c $Header$
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzoom,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
 
        IMPLICIT NONE
@@ -13,14 +18,10 @@
 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 transition ,   normalement  = 1  .
-
-c  N.B :  on doit avoir :  grossism * dzoom  <   1 .
-c         **************
-c
-c    Pour Indoex , on a pris :
-c         *******
-c    grossism = 2.5 , dzoom = 7/24  en x et  y  , pour iim = 128 et jjm=64
-c    yzoomdeg = 0.  , tau = 1.  et delaty = 10.
+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
@@ -29,10 +30,11 @@
 
        INTEGER      nmax , nmax2
-       PARAMETER (  nmax = 50000, nmax2 = 2*nmax )
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
 c
 c
 c     .......  arguments  d'entree    .......
 c
-       REAL yzoomdeg, grossism,dzoom,tau , deltay
+       REAL yzoomdeg, grossism,dzoom,tau 
+c         ( rentres  par  run.def )
 
 c     .......  arguments  de sortie   .......
@@ -42,17 +44,18 @@
 
 c
-c    ..... Champs  locaux    .....
+c     .....     champs  locaux    .....
 c
      
-       REAl ylat(jjp1), yprim(jjp1)
-       REAL yuv
-       REAL ytild(0:nmax2)
-       REAL fhyp(0:nmax),ffdx(0:nmax),beta,Ytprim(0:nmax2)
-       SAVE Ytprim, ytild,Yf
-       REAL Yf(0:nmax2),yypr(0:nmax2)
-       REAL yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
-       REAL pi,depi,pis2,epsilon,yzoom
-       REAL yo1,yi,ylon2,fxm,ymoy,yint,Yprimin
-       REAL ypn,deply,y00
+       REAL*8 ylat(jjp1), yprim(jjp1)
+       REAL*8 yuv
+       REAL*8 yt(0:nmax2)
+       REAL*8 fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL*8 Yf(0:nmax2),yypr(0:nmax2)
+       REAL*8 yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL*8 pi,depi,pis2,epsilon,y0,pisjm
+       REAL*8 yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL*8 yfi,Yf1,ffdy
+       REAL*8 ypn,deply,y00
        SAVE y00, deply
 
@@ -60,71 +63,122 @@
        INTEGER jpn,jjpn
        SAVE jpn
-
+       REAL*8 a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL*8 fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL*8     heavyside
+       EXTERNAL   heavyside
 
        pi       = 2. * ASIN(1.)
        depi     = 2. * pi
        pis2     = pi/2.
-       epsilon  = 1.e-6
-       yzoom    = yzoomdeg * pi/180. 
-
-
+       pisjm    = pi/ FLOAT(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzoom.LT.1.)  THEN
+         dzoom = dzoom * pi
+       ELSEIF( dzoom.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzoom * 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 
-        ytild(i) = FLOAT(i) /nmax2
-       IF( ytild(i).EQ.0.5 )  ytild(i) = ytild(i) + 1.e-6
-       ENDDO
-
-       DO i = 1, nmax
-        fhyp(i) = TANH ( ( ytild(i) - 0.5*(1.- dzoom) )          /
-     ,                 ( tau * ytild(i) * ( 0.5 -ytild(i))) )
-       ENDDO
-
-       fhyp(   0  ) = - 1.
-       fhyp( nmax ) =   1.
+        yt(i) = - pis2  + FLOAT(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
-       ffdx( 0 ) = 0.
-
-       DO i = 1, nmax
-        ymoy    = 0.5 * ( ytild(i-1) + ytild( i ) )
-        fxm     = TANH ( ( ymoy - 0.5 * ( 1. - dzoom ) )    /
-     ,                 ( tau * ymoy * ( 0.5 -ymoy)) )
-        ffdx(i) = ffdx(i-1) + fxm * ( ytild(i) - ytild(i-1) )
-       ENDDO
-
-        beta  = ( grossism * ffdx(nmax) - 0.5 ) / ( ffdx(nmax) - 0.5 )
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
 c
 c   .....  calcul  de  Ytprim   .....
 c
        
-       DO i = 0, nmax
+       DO i = 0, nmax2
         Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
        ENDDO
-c   
-       DO i = 0, nmax
-        Ytprim( nmax2 - i ) = Ytprim( i )
-       ENDDO
-c
 
 c   .....  Calcul  de  Yf     ........
 
-        Yf(0) = 0.
-       DO i = 1, nmax
-        ymoy    = 0.5 * ( ytild(i-1) + ytild( i ) )
-        fxm     = TANH ( ( ymoy - 0.5 * ( 1. - dzoom ) )    /
-     ,                 ( tau * ymoy * ( 0.5 -ymoy)) )
-        yypr(i)    = beta + ( grossism - beta ) * fxm
-       ENDDO
-
-       DO i = 1,nmax
-         yypr(nmax2-i+1) = yypr(i)
-       ENDDO
-
-        DO i=1,nmax2
-         Yf(i)   = Yf(i-1) + yypr(i) * ( ytild(i) - ytild(i-1) )
-        ENDDO
-c
-c
+       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    ****************************************************************
@@ -133,4 +187,5 @@
 c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
 c
+      WRITE(6,18)
 c
       DO 5000  ik = 1,4
@@ -149,28 +204,21 @@
          jlat = jjm 
        ENDIF
-        
-c
+c
+       yo1   = 0.
        DO 1500 j =  1,jlat
-
-        ylon2 =  ( FLOAT(j)  + yuv  -1.) / FLOAT(jjm) 
-
         yo1   = 0.
-        yi    = ylon2
-
-c
-       DO 500 iter = 1,300
-
+        ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
        DO 250 it =  nmax2,0,-1
-        IF( yi.GE.ytild(it))  GO TO 350
+        IF( yfi.GE.Yf(it))  GO TO 350
 250    CONTINUE
-
        it = 0
-       yi = ytild(it)
-
 350    CONTINUE
 
+       yi = yt(it)
        IF(it.EQ.nmax2)  THEN
         it       = nmax2 -1
-        Yf(it+1) = 1.
+        Yf(it+1) = pis2
        ENDIF
 c  .................................................................
@@ -179,41 +227,42 @@
 c  .................................................................
 
-       yint   = ( Yf(it+1)-Yf(it) ) / ( ytild(it+1)-ytild(it) )      * 
-     +                    ( yi-ytild(it) )  +  Yf(it)
-      Yprimin = ( Ytprim(it+1)-Ytprim(it) )/ ( ytild(it+1)-ytild(it) ) *
-     +                    ( yi-ytild(it) )  +  Ytprim(it)
-       yi = yi - (yint-ylon2)/Yprimin
-
-      IF( ABS(yi-yo1).LE.epsilon) GO TO 550
-      yo1 = 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
-      PRINT *,' ***   PAS DE SOLUTION  ****  ',j,ylon2,iter
-        STOP 4
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
 550   CONTINUE
-
-       yprim(j)    = pi /( FLOAT(jjm) *  Yprimin)
-       yvrai(j)    = pi *  (yi - 0.5) + yzoom
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
 
 1500    CONTINUE
-
-cc          print *,' LAT avant reorgan '
-cc         print 68,(yyvrai(j),j=1,jlat)
 
        DO j = 1, jlat -1
         IF( yvrai(j+1). LT. yvrai(j) )  THEN
-         PRINT *,' PBS.  avec  rlat(',j+1,' plus petit que rlat(',j,
-     ,   ')'
-         STOP
-        ENDIF
-       ENDDO
-
-        PRINT 18
-        PRINT *,'Reorganisation des latitudes pour avoir entre - pi/2 ',
-     ,  ' et  pi/2 '
-c
-           
+         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 - deltay * pi/180.
+           ypn = pis2 
           DO j = jlat,1,-1
            IF( yvrai(j).LE. ypn ) GO TO 1502
@@ -239,11 +288,7 @@
          ENDDO
 
-
-
 c      ***********   Fin de la reorganisation     *************
 c
  1600   CONTINUE
-
-
 
        DO j = 1, jlat
@@ -256,33 +301,35 @@
         ENDDO
 
-
         IF( ik.EQ.1 )  THEN
-        PRINT 18
-        PRINT *, ' YLAT  en U   apres ( en  deg. ) '
-        PRINT 68,(yvrai(j),j=1,jlat)
-        PRINT *,' YPRIM '
-        PRINT 68,( yprim(j),j=1,jlat)
+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
-c
+
         ELSE IF ( ik.EQ. 2 )  THEN
-        PRINT 18
-        PRINT *, ' YLAT   en V  apres ( en  deg. ) '
-        PRINT 68,(yvrai(j),j=1,jlat)
-        PRINT *,' YPRIM '
-        PRINT 68,( yprim(j),j=1,jlat)
+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
-c
+
         ELSE IF ( ik.EQ. 3 )  THEN
-        PRINT 18
-        PRINT *, ' YLAT  en U + 0.75  apres ( en  deg. ) '
-        PRINT 68,(yvrai(j),j=1,jlat)
-        PRINT *,' YPRIM '
-        PRINT 68,( yprim(j),j=1,jlat)
+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 )
@@ -291,19 +338,36 @@
 
         ELSE IF ( ik.EQ. 4 )  THEN
-        PRINT 18
-        PRINT *, ' YLAT en U + 0.25  apres ( en  deg. ) '
-        PRINT 68,(yvrai(j),j=1,jlat)
-        PRINT *,' YPRIM '
-        PRINT 68,( yprim(j),j=1,jlat)
+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)
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/gcm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gcm.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/gcm.F	(revision 300)
@@ -1,4 +1,6 @@
 
       PROGRAM gcm
+
+      USE IOIPSL
 
       IMPLICIT NONE
@@ -20,11 +22,13 @@
 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 de Van-leer pour l'advection de
-c         q  , en faisant iadv = 3  dans   traceur  (29/04/97) .
+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 de Van-leer pour l'advection de
+c        q  , en faisant iadv = 3  dans   traceur  (29/04/97) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
 c
 c-----------------------------------------------------------------------
@@ -115,4 +119,5 @@
 
 
+      INTEGER fluxid, fluxvid,fluxdid
       integer histid, histvid, histaveid
       real time_step, t_wrt, t_ops
@@ -129,8 +134,16 @@
       character*80 abort_message
 
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+C Run nudge
+      LOGICAL ok_nudge
+      PARAMETER (ok_nudge = .false.)
+
 c-----------------------------------------------------------------------
 c   Initialisations:
 c   ----------------
 
+      abort_message = 'last timestep reached'
       modname = 'gcm'
       descript = 'Run GCM LMDZ'
@@ -138,4 +151,10 @@
       dynhist_file = 'dyn_hist.nc'
       dynhistave_file = 'dyn_hist_ave.nc'
+
+      if (true_calendar) then
+        call ioconf_calendar('gregorian')
+      else
+        call ioconf_calendar('360d')
+      endif
 c-----------------------------------------------------------------------
 c
@@ -146,4 +165,6 @@
 c     iadv = 2    shema   amont
 c     iadv = 3    shema  Van-leer
+c     iadv = 4    schema  Van-leer + humidite specifique
+c                        Modif F.Codron
 c 
 c     dans le tableau q(ij,l,iq) , iq = 1  pour l'eau vapeur
@@ -157,5 +178,20 @@
       ENDDO
 c
-      DO  iq = 1, nqmx
+       IF( iadv(1).EQ.1 ) PRINT *,' Choix du shema humidite specifique'
+     * ,' pour la vapeur d''eau'
+       IF( iadv(1).EQ.2 ) PRINT *,' Choix du shema  amont',' pour la'
+     * ,' vapeur d''eau '
+       IF( iadv(1).EQ.3 ) PRINT *,' Choix du shema  Van-Leer ',' pour'
+     * ,'la vapeur d''eau'
+       IF( iadv(1).EQ.4 ) PRINT *,' Choix du shema  Van-Leer + humidite'
+     * ,' specifique pour la vapeur d''eau'
+c
+       IF( iadv(1).LE.0.OR.iadv(1).GT.4 )   THEN
+        PRINT *,' Erreur dans le choix de iadv (1).Corriger et repasser
+     * ,  car  iadv(1) = ', iadv(1)
+         CALL ABORT
+       ENDIF
+
+      DO  iq = 2, nqmx
        IF( iadv(iq).EQ.1 ) PRINT *,' Choix du shema humidite specifique'
      * ,' pour le traceur no ', iq
@@ -164,8 +200,16 @@
        IF( iadv(iq).EQ.3 ) PRINT *,' Choix du shema  Van-Leer ',' pour'
      * ,'le traceur no ', iq
-       IF( iadv(iq).LE.0.OR.iadv(iq).GT.3 )   THEN
+
+       IF( iadv(iq).EQ.4 )  THEN
+         PRINT *,' Le shema  Van-Leer + humidite specifique ',
+     * ' est  uniquement pour la vapeur d eau .'
+         PRINT *,' Corriger iadv( ',iq, ')  et repasser ! '
+         CALL ABORT
+       ENDIF
+
+       IF( iadv(iq).LE.0.OR.iadv(iq).GT.4 )   THEN
        PRINT *,' Erreur dans le  choix de  iadv . Corriger et repasser
      * . '
-         STOP 
+         CALL ABORT 
        ENDIF
       ENDDO
@@ -174,5 +218,5 @@
       numvanle = nqmx + 1
       DO  iq = 1, nqmx
-        IF( iadv(iq).EQ.3.AND.first ) THEN
+        IF((iadv(iq).EQ.3.OR.iadv(iq).EQ.4).AND.first ) THEN
           numvanle = iq
           first    = .FALSE.
@@ -181,10 +225,10 @@
 c
       DO  iq = 1, nqmx
-        IF( iadv(iq).NE.3.AND.iq.GT.numvanle )   THEN
+      IF( (iadv(iq).NE.3.AND.iadv(iq).NE.4).AND.iq.GT.numvanle )  THEN
           PRINT *,' Il y a discontinuite dans le choix du shema de ',
      *    'Van-leer pour les traceurs . Corriger et repasser . '
-           STOP
-        ENDIF
-        IF( iadv(iq).LT.1.OR.iadv(iq).GT.3 )    THEN
+           CALL ABORT
+      ENDIF
+        IF( iadv(iq).LT.1.OR.iadv(iq).GT.4 )    THEN
           PRINT *,' Le choix de  iadv  est errone pour le traceur ',
      *    iq
@@ -199,5 +243,6 @@
 
 c     OPEN( 99,file ='run.def',status='old',form='formatted')
-      CALL defrun_new( 99, .TRUE. , clesphy0 )
+c      CALL defrun_new( 99, .TRUE. , clesphy0 )
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
 c     CLOSE(99)
 
@@ -261,6 +306,6 @@
       t_ops = iecri * daysec
       t_wrt = iecri * daysec
-      CALL inithist(dynhist_file,day_ini,anne_ini,time_step,
-     .              t_ops, t_wrt, nqmx, histid, histvid)
+C      CALL inithist(dynhist_file,day_ini,anne_ini,time_step,
+c     .              t_ops, t_wrt, nqmx, histid, histvid)
 
       t_ops = iperiod * time_step
@@ -282,5 +327,8 @@
 
    1  CONTINUE
-c     call nudge(itau,ucov,vcov,teta,masse,ps)
+
+      if (ok_nudge) then
+        call nudge(itau,ucov,vcov,teta,masse,ps)
+      endif
 c
 c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
@@ -364,5 +412,7 @@
 c
             CALL vanleer(numvanle,iapp_tracvl,nqmx,q,pbaru,pbarv,
-     *                             p,  masse, dq                  )
+     *                      p, masse, dq,  iadv(1), teta, pk     )
+c
+c                   ...  Modif  F.Codron  ....
 c
          ENDIF
@@ -372,5 +422,9 @@
          IF (offline) THEN
 Cmaf stokage du flux de masse pour traceurs OFF-LINE
-           CALL fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
+
+            CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     .   time_step, itau)
+
+
          ENDIF
 c
@@ -418,4 +472,8 @@
            ENDIF
 c
+
+c rajout debug
+c       lafin = .true.
+
         CALL calfis( nqmx, lafin ,rdayvrai,rday_ecri,time  ,
      $                 ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
@@ -451,5 +509,4 @@
 c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
 c
-      IF( alphax.NE. 0. ) THEN
 
         DO l  =  1, llm
@@ -467,7 +524,24 @@
         ENDDO
 
-      ENDIF
+        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
+
 
       END IF
+
+c ajout debug
+c              IF( lafin ) then  
+c                abort_message = 'Simulation finished'
+c                call abort_gcm(modname,abort_message,0)
+c              ENDIF
         
 c   ********************************************************************
@@ -521,6 +595,6 @@
                nbetat = nbetatdem
        CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi        )
-       CALL writehist( histid, histvid, nqmx, itau,vcov , 
-     ,                          ucov,teta,phi,q,masse,ps,phis)
+c       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+c     ,                          ucov,teta,phi,q,masse,ps,phis)
 
 
@@ -608,6 +682,6 @@
                   nbetat = nbetatdem
        CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi       )
-       CALL writehist( histid, histvid, nqmx, itau,vcov , 
-     ,                          ucov,teta,phi,q,masse,ps,phis)
+c       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+c     ,                          ucov,teta,phi,q,masse,ps,phis)
                ENDIF
 
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/gr_ecrit_fi.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/gr_ecrit_fi.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/gr_ecrit_fi.F	(revision 300)
@@ -0,0 +1,29 @@
+	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: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/grid_noro.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/grid_noro.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/grid_noro.F	(revision 300)
@@ -52,5 +52,5 @@
       IMPLICIT REAL(X,Z) 
       
-	  parameter(iusn=2160,jusn=1080,iext=216)
+	  parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5)
 #include "dimensions.h"
 	  REAL xusn(iusn+2*iext),yusn(jusn+2)	
@@ -77,5 +77,6 @@
       REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
       REAL zpic(imar+1,jmar),zval(imar+1,jmar)
-      integer mask(imar+1,jmar)
+c$$$ PB     integer mask(imar+1,jmar)
+      real mask(imar+1,jmar), mask_tmp(imar+1,jmar)
       real num_tot(2200,1100),num_lan(2200,1100)
 c
@@ -257,9 +258,10 @@
          IF (weight(ii,jj) .NE. 0.0) THEN
 c  Mask
-           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
-             mask(ii,jj)=1
-           else
-             mask(ii,jj)=0
-           endif
+c$$$           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
+c$$$             mask(ii,jj)=1
+c$$$           else
+c$$$             mask(ii,jj)=0
+c$$$           ENDIF
+             mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj)
 c  Mean Orography:
            zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj)
@@ -296,6 +298,9 @@
        CALL MVA9(zval,iim+1,jjm+1)
        CALL MVA9(zxtzx,iim+1,jjm+1)
-       CALL MVA9(zxtzy,iim+1,jjm+1)
-       CALL MVA9(zytzy,iim+1,jjm+1)
+       CALL MVA9(zxtzy,iim+1,jjm+1) 
+c$$$       CALL MVA9(zytzy,iim+1,jjm+1)
+C$$$   Masque prenant en compte maximum de terre
+       mask_tmp= 0.0
+       WHERE(mask .GE. epsfra) mask_tmp = 1.
 
        DO ii = 1, imar
@@ -313,15 +318,26 @@
            if(abs(xm).le.xw) xm=xw*sign(1.,xm)
 c slope: 
-           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+c$$$           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+c$$$c isotropy:
+c$$$           zgam(ii,jj)=xp/xq*mask(ii,jj)
+c$$$c angle theta:
+c$$$           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
+c$$$           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+c$$$           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+c$$$           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
+c$$$           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
+c$$$           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
+C$$* PB modif pour maque de terre fractionnaire
+c slope: 
+           zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj)
 c isotropy:
-           zgam(ii,jj)=xp/xq*mask(ii,jj)
+           zgam(ii,jj)=xp/xq*mask_tmp(ii,jj)
 c angle theta:
-           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
-           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
-           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
-           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
-           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
-           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
-
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj)
+           zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj)
+           zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj)
+           zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj)
+           zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj)
 c          print 101,ii,jj,
 c    *           zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj),
@@ -355,4 +371,5 @@
       DO jj=1,jmar
       zmea(imar+1,jj)=zmea(1,jj)
+      zphi(imar+1,jj)=zphi(1,jj)
       zpic(imar+1,jj)=zpic(1,jj)
       zval(imar+1,jj)=zval(1,jj)
@@ -420,5 +437,5 @@
       PARAMETER (ISMo=300,JSMo=200)
       REAL X(IMAR,JMAR),XF(ISMo,JSMo)
-      real weight(-1:1,-1:1)
+      real WEIGHTpb(-1:1,-1:1)
 
       if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)'
@@ -427,50 +444,53 @@
       SUM=0.
       DO IS=-1,1
-      DO JS=-1,1
-      WEIGHT(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
-      SUM=SUM+WEIGHT(IS,JS)
-      ENDDO
-      ENDDO
-
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
+          SUM=SUM+WEIGHTpb(IS,JS)
+        ENDDO
+      ENDDO
+      
+      WRITE(*,*) 'MVA9 ', IMAR, JMAR
+      WRITE(*,*) 'MVA9 ', WEIGHTpb
+      WRITE(*,*) 'MVA9 SUM ', SUM
       DO IS=-1,1
-      DO JS=-1,1
-      WEIGHT(IS,JS)=WEIGHT(IS,JS)/SUM
-      ENDDO
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM
+        ENDDO
       ENDDO
 
       DO J=2,JMAR-1
-      DO I=2,IMAR-1
-      XF(I,J)=0.
-      DO IS=-1,1
-      DO JS=-1,1
-         XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHT(IS,JS)
-      ENDDO
-      ENDDO
-      ENDDO
+        DO I=2,IMAR-1
+          XF(I,J)=0.
+          DO IS=-1,1
+            DO JS=-1,1
+              XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS)
+            ENDDO
+          ENDDO
+        ENDDO
       ENDDO
 
       DO J=2,JMAR-1
-         XF(1,J)=0.
-      IS=IMAR-1
-      DO JS=-1,1 
-         XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHT(-1,JS)
-      ENDDO
-      DO IS=0,1 
-      DO JS=-1,1 
-         XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHT(IS,JS)
-      ENDDO
-      ENDDO
-         XF(IMAR,J)=XF(1,J)
+        XF(1,J)=0.
+        IS=IMAR-1
+        DO JS=-1,1 
+          XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS)
+        ENDDO
+        DO IS=0,1 
+          DO JS=-1,1 
+            XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS)
+          ENDDO
+        ENDDO
+        XF(IMAR,J)=XF(1,J)
       ENDDO
 
       DO I=1,IMAR
-      XF(I,1)=XF(I,2)
-      XF(I,JMAR)=XF(I,JMAR-1)
+        XF(I,1)=XF(I,2)
+        XF(I,JMAR)=XF(I,JMAR-1)
       ENDDO
 
       DO I=1,IMAR
-      DO J=1,JMAR
-         X(I,J)=XF(I,J)
-      ENDDO
+        DO J=1,JMAR
+          X(I,J)=XF(I,J)
+        ENDDO
       ENDDO
 
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/grilles_gcm_netcdf.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/grilles_gcm_netcdf.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/grilles_gcm_netcdf.F	(revision 300)
@@ -0,0 +1,286 @@
+c
+c $Header$
+c
+
+      PROGRAM create_fausse_var
+C
+      IMPLICIT NONE
+C
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+      real temp(iim+1,jjm+1)
+#include "netcdf.inc"
+
+c Attributs netcdf sortie
+        character*64 fich_out
+        integer*4 ncid_out,rcode_out
+        integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid
+        integer*4 out_varid
+        integer*4 out_lonudim,out_lonvdim
+        integer*4 out_latudim,out_latvdim,out_dim(3)
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+
+      integer start(4),count(4)
+
+	integer status,i,j
+        real rlatudeg(jjp1),rlatvdeg(jjm)
+        real rlonudeg(iip1),rlonvdeg(iip1)
+
+      real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
+      real acoslat,dxkm,dykm,resol(iip1,jjp1)
+
+#include "serre.h"
+#include "fxyprim.h"
+
+      print*,'OK0'
+
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+
+      preff = 101325.
+      pa= 50000.
+
+      open(99,file='run.def',status='old',form='formatted')
+      CALL defrun_new( 99, .TRUE.,clesphy0 )
+      close(99)
+      CALL iniconst
+      CALL inigeom
+
+
+      print*,'OK1'
+      do j=1,jjp1
+         rlatudeg(j)=rlatu(j)*180./pi
+      enddo
+      do j=1,jjm
+         rlatvdeg(j)=rlatv(j)*180./pi
+      enddo
+
+      do i=1,iip1
+         rlonudeg(i)=rlonu(i)*180./pi
+         rlonvdeg(i)=rlonv(i)*180./pi
+      enddo
+
+
+      print*,'OK2'
+c  2 ----- OUVERTURE DE LA SORTIE NETCDF
+c ---------------------------------------------------
+c CREATION OUTPUT
+c ouverture fichier netcdf de sortie out
+        fich_out='grilles_gcm.nc'
+
+        status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out)
+        status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
+        status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
+        status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
+        status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
+
+
+      print*,'OK3'
+c   Longitudes en u
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim,
+     %  out_lonuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',
+     %  9,'Longitude en u')
+
+c   Longitudes en v
+        print *,'OUTID: ',ncid_out
+        status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim,
+     %  out_lonvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units',
+     %  12,'degrees_east')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name',
+     %  9,'Longitude en v')
+
+c   Latitude en u
+        status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim,
+     %  out_latuid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name',
+     %  8,'Latitude en u')
+
+c  Latitude en v
+        status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim,
+     %  out_latvid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units',
+     %  13,'degrees_north')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name',
+     %  8,'Latitude en v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonudim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+c   ecriture de la grille v
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latvdim
+        status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point v')
+
+c   ecriture de la grille u
+        out_dim(1)=out_lonvdim
+        out_dim(2)=out_latudim
+        status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim,
+     %  out_varid)
+        call handle_err(status)
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
+     %  6,'Kelvin')
+        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
+     %  16,'Grille aux point u')
+
+
+      print*,'OK4'
+        status=NF_ENDDEF(ncid_out)
+c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
+c --------------------------------------------------------
+c 3-b- Ecriture de la grille pour la sortie
+c rajoute l'ecriture de la grille
+
+#ifdef NC_DOUBLE
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#else
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
+      status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
+#endif
+
+        start(1)=1
+        start(2)=1
+        start(3)=1
+        start(4)=1
+
+        count(1)=iim+1
+        count(2)=jjm+1
+        count(3)=1
+        count(4)=1
+
+        do j=1,jjm+1
+           do i=1,iim+1
+              temp(i,j)=mod(i,2)+mod(j,2)
+           enddo
+        enddo
+
+#ifdef NC_DOUBLE
+        status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start,
+     s  count,temp)
+#else
+        status=NF_PUT_VARA_REAL(ncid_out,out_varid,start,
+     s  count,temp)
+#endif
+
+
+c fermeture du fichier netcdf
+        call ncclos(ncid_out,rcode_out)
+        write(*,*) 'Fermeture: ',fich_out
+
+
+      print*,'OK5'
+c   Ecriture grads
+      open (20,file='grille.dat',form='unformatted',access='direct'
+     s      ,recl=4*ip1jmp1)
+      write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
+      write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
+      do j=2,jjm
+         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
+c        dlat2(j)=180.*fyprim(float(j))/pi
+      enddo
+      do i=2,iip1
+         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
+c        dlon2(i)=180.*fxprim(float(i))/pi
+      enddo
+      do j=2,jjm
+         dykm=(rlatv(j)-rlatv(j-1))*6400.
+         acoslat=6400.*cos(rlatu(j))
+         do i=2,iip1
+            dxkm=acoslat*(rlonu(i)-rlonu(i-1))
+            resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm)
+         enddo
+         resol(1,j)=resol(iip1,j)
+      enddo
+      write(20,rec=3) resol
+      dlon1(1)=dlon1(iip1)
+      dlon2(1)=dlon2(iip1)
+      write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=5) ((dlon2(i),i=1,iip1),j=1,jjp1)
+      write(20,rec=6) ((dlat1(j),i=1,iip1),j=1,jjp1)
+      write(20,rec=7) ((dlat2(j),i=1,iip1),j=1,jjp1)
+        
+      open (21,file='grille.ctl',form='formatted')
+
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      write(21,'(a5,1x,a40)')
+     &       'DSET ','^grille.dat'
+
+      write(21,'(a12)') 'UNDEF 1.0E30'
+      write(21,'(a5,1x,a40)') 'TITLE ','grille'
+      call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF')
+      call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF')
+      call formcoord(21,1,0.,1.,.false.,'ZDEF')
+      write(21,'(a4,i10,a30)')
+     &       'TDEF ',1,' LINEAR 23OCT1994 3hr '
+      write(21,'(a4,2x,i5)') 'VARS',7
+      write(21,'(a18)') 'grille 0 99 grille'
+      write(21,'(a18)') 'gril   0 99 gril  '
+      write(21,'(a29)') 'resol   0 99 resolution (km)  '
+      write(21,'(a18)') 'dlon1  0 99 dlon1 '
+      write(21,'(a18)') 'dlon2  0 99 dlon2 '
+      write(21,'(a18)') 'dlat1  0 99 dlat1 '
+      write(21,'(a18)') 'dlat2  0 99 dlat2 '
+      write(21,'(a7)') 'ENDVARS'
+
+
+
+
+
+      print*,'OK6'
+	end
+
+
+
+        subroutine handle_err(status)
+#include "netcdf.inc"
+
+
+        integer status
+        print *,'handle code err: ',NF_NOERR
+        IF (status.NE.nf_noerr) THEN
+                print *,NF_STRERROR(status)
+                stop 'stopped'
+        ENDIF
+        END
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/heavyside.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/heavyside.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/heavyside.F	(revision 300)
@@ -0,0 +1,21 @@
+c
+c $Header$
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL*8 heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/inigeom.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inigeom.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/inigeom.F	(revision 300)
@@ -1,22 +1,18 @@
+c
+c $Header$
+c
       SUBROUTINE inigeom
 c
 c     Auteur :  P. Le Van
-c    .....................
-c
-c   ............      Version  du 20/12/98     ........................
+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
-      REAL        deltay, tauy, taux
-      PARAMETER ( deltay =  0. , tauy = 1. , taux = 1. )
-c
-c     deltay  est ( en degres ) le deplacement eventuel en Y du zoom
-cc    taux  et  tauy  sont  les raideurs   du  zoom
-c
 c
 #include "dimensions.h"
@@ -50,10 +46,6 @@
       SAVE rlonm025,xprimm025,rlonp025,xprimp025
 
-
-
-c----------------------------------------------------------------------
       REAL      SSUM
       EXTERNAL  SSUM
-c
 c
 c
@@ -62,5 +54,4 @@
 c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
 c   -                                                                -
-c   ------------------------------------------------------------------
 c   ------------------------------------------------------------------
 c
@@ -168,5 +159,5 @@
 c
 c
-      PRINT 3
+      WRITE(6,3) 
  3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
      * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
@@ -191,10 +182,10 @@
       ENDIF
 
-      PRINT *,' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
      *  nitergdiv,nitergrot,niterh
 c
       pi    = 2.* ASIN(1.)
 c
-      PRINT 990
+      WRITE(6,990) 
 
 c     ----------------------------------------------------------------
@@ -205,5 +196,5 @@
        IF( ysinus )  THEN
 c
-        PRINT *,' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
 c
 c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
@@ -215,5 +206,5 @@
        ELSE
 c
-        PRINT *,' *** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
 
 c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
@@ -267,11 +258,11 @@
       ELSE
 c
-c   ....  utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
 c   .....................................................................
 
-       PRINT *,'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
-
-       CALL fxyhyper( clat, grossismy, dzoomy, tauy, deltay  ,
-     ,               clon, grossismx, dzoomx, taux          ,
+      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 )
@@ -387,9 +378,8 @@
 c
       IF ( j. eq. jjp1 )  THEN
-
        yprp               = yprimu2(j-1)
        rlatp              = rlatu2 (j-1)
-cc       yprp             = fyprim( FLOAT(j) - 0.25 )
-cc       rlatp            = fy    ( FLOAT(j) - 0.25 )
+ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
+ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
 c
       coslatp             = COS( rlatp )
@@ -425,8 +415,8 @@
         rlatm    = rlatu1 (  j  )
         yprm     = yprimu1(  j  )
-c         rlatp    = fy    ( FLOAT(j) - 0.25 )
-c         yprp     = fyprim( FLOAT(j) - 0.25 )
-c         rlatm    = fy    ( FLOAT(j) + 0.25 )
-c         yprm     = fyprim( FLOAT(j) + 0.25 )
+cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
+cc         yprp     = fyprim( FLOAT(j) - 0.25 )
+cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
+cc         yprm     = fyprim( FLOAT(j) + 0.25 )
 
          coslatm  = COS( rlatm )
@@ -490,5 +480,4 @@
   36  CONTINUE
 c
-c   ....  Modif  P. Le Van  ( 4/07/96 )  .....
 c
       aire    (iip1,j) = aire    (1,j)
@@ -620,5 +609,5 @@
          aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
       ENDDO
-c
+
 c
 c   calcul des aires aux  poles :
@@ -666,30 +655,43 @@
 c-----------------------------------------------------------------------
 c
-       PRINT *,' INIGEOM  RLONV '
+       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
-       PRINT 400,rlonvv
-c
-       PRINT *,' RLATV '
+       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
-       PRINT 400,(rlatuu(i),i=1,jjm)
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
 c
         DO i=1,iip1
           rlonvv(i)=rlonu(i)*180./pi
         ENDDO
-       PRINT *,' RLONU '
-       PRINT 400,rlonvv
-c
-       PRINT *,' RLATU '
+       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
-       PRINT 400,(rlatuu(i),i=1,jjp1)
-c
+       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
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/integrd.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/integrd.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/integrd.F	(revision 300)
@@ -91,16 +91,14 @@
       ENDDO
 c
-      IF( alphax.NE.0. )   THEN
-        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
+      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 ...
@@ -136,17 +134,15 @@
 c
 c
-      IF( alphax.NE.0. )   THEN
-        DO  ij   = 1, iim
+      DO  ij   = 1, iim
         tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
         tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
-        ENDDO
+      ENDDO
         tpn      = SSUM(iim,tppn,1)/apoln
         tps      = SSUM(iim,tpps,1)/apols
 
-        DO ij   = 1, iip1
+      DO ij   = 1, iip1
         teta(   ij   ,l)  = tpn
         teta(ij+ip1jm,l)  = tps
-        ENDDO
-      ENDIF
+      ENDDO
 c
 
@@ -197,25 +193,23 @@
 c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
 c
-      IF( alphax.NE.0. )   THEN
-
-        DO iq = 1, nq
-          DO l = 1, llm
-
-             DO ij = 1, iim
+
+      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
+           ENDDO
              qpn  =  SSUM(iim,qppn,1)/apoln
              qps  =  SSUM(iim,qpps,1)/apols
 
-             DO ij = 1, iip1
+           DO ij = 1, iip1
              q(   ij   ,l,iq)  = qpn
              q(ij+ip1jm,l,iq)  = qps
-             ENDDO
-
-          ENDDO
-        ENDDO
-
-      ENDIF
+           ENDDO
+
+        ENDDO
+      ENDDO
+
 
          CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/lectflux.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/lectflux.F	(revision 3)
+++ 	(revision )
@@ -1,233 +1,0 @@
-      SUBROUTINE lectflux(irec,massem,pbarun,pbarvn,wn,tetan,phin,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf,
-     s     frac_impa,frac_nucl,phis)
-
-      IMPLICIT NONE
-
-#include "dimensions.h"
-#include "paramet.h"
-
-#include "comvert.h"
-#include "comconst.h"
-#include "comgeom2.h"
-
-#include "tracstoke.h"
-
-      integer irec,nrec,i,j
-
-      integer ngridmx,ig,l
-      parameter (ngridmx=iim*(jjm-1)+2)
-      INTEGER nbsrf
-      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
-
-      real zmfd(ngridmx,llm),zde_d(ngridmx,llm),zen_d(ngridmx,llm)
-      real zmfu(ngridmx,llm),zde_u(ngridmx,llm),zen_u(ngridmx,llm)
-      real coefkz(ngridmx,llm)
-      real frac_impa(ngridmx,llm),frac_nucl(ngridmx,llm)
-      real yu1(ngridmx), yv1(ngridmx)
-      real ftsol(ngridmx,nbsrf),pctsrf(ngridmx,nbsrf)
-      integer imfu,imfd,ien_u,ide_u,
-     s      ien_d,ide_d,
-     s      icoefkz,izu1,izv1,
-     s      itsol,ipsf,
-     s      ilei, ilec
-      parameter(imfu=1,imfd=llm+1,ien_u=2*llm+1,ide_u=3*llm+1,
-     s      ien_d=4*llm+1,ide_d=5*llm+1,
-     s      icoefkz=6*llm+1,
-     s      ilei=7*llm+1,ilec=8*llm+1,
-     s      izu1=9*llm+1,izv1=9*llm+2,
-     s      itsol=9*llm+3,ipsf=9*llm+3+nbsrf)
-      logical avant
-
-      real massefi(ngridmx,llm)
-
-      real massem(ip1jmp1,llm),tetan(ip1jmp1,llm)
-      real pbarun(iip1,jjp1,llm),pbarvn(iip1,jjm,llm)
-      real pbarvst(iip1,jjp1,llm)
-      real wn(iip1,jjp1,llm),phin(iip1,jjp1,llm)
-      real phis(iip1,jjp1)
-
-      real airefi(ngridmx)
-
-      real xlecn(ngridmx,9*llm+2+2*nbsrf)
-
-      real zcontrole(ngridmx),zmass,tmpdyn(iip1,jjp1),zflux
-
-      real ziadvtrac,zrec,ziadvtrac2,zrec2
-      real zim,zjm,zlm,zklon,zklev
-
-      real zpi
-
-      zpi=2.*asin(1.)
-
-
-c==================================================================
-c   Si le numero du record est 0 alors: INITIALISATION
-c==================================================================
-c
-      print*,'ENTREE DANS LECTFLUX'
-        print*,'IREC=',IREC
-      if(irec.eq.0) then
-
-        print*,'IREC==',0
-
-C test         call inigeom
-
-c==================================================================
-c   ouverture des fichiers
-c==================================================================
-
-c   Fichier fluxmass
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
-#endif
-      open(47,file='fluxmass',form='unformatted',
-     s     access='direct'
-     s     ,recl=4*(6*ijp1llm))
-      read(47,rec=1) zrec,dtvr,ziadvtrac,zim,zjm,zlm,
-     s   rlonu,rlonv,rlatu,rlatv,aire
-     s    ,phis
-      print*,'zrec,dtvr,ziadvtrac,zim,zjm,zlm'
-      print*,zrec,dtvr,ziadvtrac,zim,zjm,zlm
-      print*,rlonv
-
-
-
-c  Fichier physique
-c  Fichier lessivage (supprime les donnees utiles sont dans "physique")
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:physique")
-#endif
-      open(49,file='physique',form='unformatted',
-     s     access='direct'
-     s     ,recl=4*ngridmx*(9*llm+2+2*nbsrf))
-      read(49,rec=1) zrec2,ziadvtrac2,zklon,zklev
-      print*,'Entete du fichier physique'
-      print*,zrec2,ziadvtrac2,zklon,zklev
-
-      nrec=zrec
-      print*,'nrec=',nrec
-
-      istdyn=ziadvtrac
-      istphy=ziadvtrac2
-
-c==================================================================
-c   Fin des initialisations
-      else ! irec=0
-c==================================================================
-
-
-c-----------------------------------------------------------------------
-c   Lecture des fichiers fluxmass et  physique:
-c   -----------------------------------------------------
-
-c  Variables dynamiques
-         read(47,rec=irec) massem,pbarun,pbarvst,wn,tetan,phin
-        do l=1,llm
-           do j=1,jjm
-              do i=1,iip1
-                 pbarvn(i,j,l)=pbarvst(i,j,l)
-              enddo
-           enddo
-        enddo
-
-c  Variables physiques
-         read(49,rec=irec) ((xlecn(ig,l),ig=1,ngridmx),
-     s                                    l=1,9*llm+2+2*nbsrf)
-
-       do l=1,llm
-          do ig=1,ngridmx
-             coefkz(ig,l)=xlecn(ig,icoefkz+l-1)
-             frac_impa(ig,l)=xlecn(ig,ilei+l-1)
-             frac_nucl(ig,l)=xlecn(ig,ilec+l-1)
-          enddo
-       enddo
-       do l=1,nbsrf
-          do ig=1,ngridmx
-             ftsol(ig,l)=xlecn(ig,itsol+l-1)
-             pctsrf(ig,l)=xlecn(ig,ipsf+l-1)
-          enddo
-       enddo
-       do ig=1,ngridmx
-          yv1(ig)=xlecn(ig,izv1)
-          yu1(ig)=xlecn(ig,izu1)
-       enddo
-C
-      if(avant) then
-c   Simu directe
-       do l=1,llm
-          do ig=1,ngridmx
-             zmfu(ig,l)=xlecn(ig,imfu+l-1)
-             zmfd(ig,l)=xlecn(ig,imfd+l-1)
-             zde_u(ig,l)=xlecn(ig,ide_u+l-1)
-             zen_u(ig,l)=xlecn(ig,ien_u+l-1)
-             zde_d(ig,l)=xlecn(ig,ide_d+l-1)
-             zen_d(ig,l)=xlecn(ig,ien_d+l-1)
-          enddo
-       enddo
-      else
-c   Simu retro
-       do l=1,llm
-          do ig=1,ngridmx
-             zmfd(ig,l)=-xlecn(ig,imfu+l-1)
-             zmfu(ig,l)=-xlecn(ig,imfd+l-1)
-             zen_d(ig,l)=xlecn(ig,ide_u+l-1)
-             zde_d(ig,l)=xlecn(ig,ien_u+l-1)
-             zen_u(ig,l)=xlecn(ig,ide_d+l-1)
-             zde_u(ig,l)=xlecn(ig,ien_d+l-1)
-          enddo
-       enddo
-      endif
-
-c-----------------------------------------------------------------------
-c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
-c-----------------------------------------------------------------------
-
-      print*,'Ap redec irec'
-
-         call gr_dyn_fi(llm,iip1,jjp1,ngridmx,massem,massefi)
-
-         do ig=1,ngridmx
-            zcontrole(ig)=1.
-         enddo
-c   zmass=(max(massem(ig,l),massem(ig,l-1))/airefi(ig)
-         do l=2,llm
-            do ig=1,ngridmx
-               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
-               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
-               if(zflux.gt.0.9*zmass) then
-                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
-               endif
-            enddo
-         enddo
-
-         do ig=1,ngridmx
-            if(zcontrole(ig).lt.0.99999) then
-               print*,'ATTENTION !!! on reduit les flux de masse '
-               print*,'convectifs au point ig=',ig
-            endif
-         enddo
-
-         call gr_fi_dyn(1,ngridmx,iip1,jjp1,zcontrole,tmpdyn)
-
-         do l=1,llm
-            do ig=1,ngridmx
-               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
-               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
-               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
-               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
-               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
-               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
-            enddo
-         enddo
-
-
-      endif ! irec=0
-
-
-      RETURN
-      END
-
-
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/lectfluxnc.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/lectfluxnc.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/lectfluxnc.F	(revision 300)
@@ -0,0 +1,218 @@
+c
+c $Header$
+c
+      SUBROUTINE lectfluxnc(irec,massem,pbarun,pbarvn,wn,tetan,phin,
+     s     nrec,avant,airefi,phisfi,
+     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phis)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+#include "tracstoke.h"
+
+      integer irec,nrec,i,j
+
+      integer klon,ig,l
+      parameter (klon=iim*(jjm-1)+2)
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+
+c Convection
+      real*4 zmfd(klon,llm),zde_d(klon,llm),zen_d(klon,llm)
+      real*4 zmfu(klon,llm),zde_u(klon,llm),zen_u(klon,llm)
+      real*4 mfd(klon,llm),de_d(klon,llm),en_d(klon,llm)
+      real*4 mfu(klon,llm),de_u(klon,llm),en_u(klon,llm)
+	real*4 t(klon,llm)
+      real zdtvr
+	
+	real*4 airedy(iip1,jjp1)
+      real*4 rlonu_dy(iip1,jjp1),rlonv_dy(iip1,jjm),
+     . rlatu_dy(iip1,jjp1),rlatv_dy(iip1,jjm)
+
+      real*4 coefkz(klon,llm)
+      real*4 frac_impa(klon,llm),frac_nucl(klon,llm)
+      real*4 yu1(klon), yv1(klon)
+      real*4 ftsol(klon,nbsrf),pctsrf(klon,nbsrf)
+
+      logical avant
+
+      real massefi(klon,llm)
+
+c   Flux masse
+      real*4 massem(iip1,jjp1,llm),tetan(iip1,jjp1,llm)
+      real*4 pbarun(iip1,jjp1,llm),pbarvn(iip1,jjm,llm)
+      real*4 pbarvst(iip1,jjp1,llm)
+      real*4 wn(iip1,jjp1,llm),phin(iip1,jjp1,llm)
+      real*4 phis(iip1,jjp1)
+
+      real*4 airefi(klon),phisfi(klon)
+
+      real zcontrole(klon),zmass,tmpdyn(iip1,jjp1),zflux
+
+      real ziadvtrac,ziadvtrac2,zrec2
+      integer zim,zjm,zlm,zklon,zklev,zrec
+
+      real zpi
+
+      zpi=2.*asin(1.)
+
+
+c==================================================================
+c   Si le numero du record est 0 alors: INITIALISATION
+c==================================================================
+c
+      print*,'ENTREE DANS LECTFLUXNC'
+        print*,'IREC=',IREC
+
+      if(irec.eq.0) then
+
+        print*,'IREC==',0
+
+C test         call inigeom
+
+c==================================================================
+c   ouverture des fichiers
+c==================================================================
+	
+	CALL read_dstoke(0,zdtvr,ziadvtrac,ziadvtrac2)
+	
+	CALL read_fstoke0(0,
+     .  zrec,zim,zjm,zlm,
+     .   rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,airedy,phis,
+     .   massem,pbarun,pbarvn,wn,tetan,phin)
+c 
+	if(physic)then	
+	CALL read_pstoke0(0,
+     .   zrec,zklon,zklev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefkz,
+     .   frac_impa,frac_nucl,yu1,yv1,ftsol,pctsrf)
+	endif
+	
+	dtvr=zdtvr	
+	nrec=zrec
+        print*,'nrec=',nrec
+	
+	print*, 'Lecture de defstoke.nc'
+	print*, 'Ds lectfluxnc dtvr = ', dtvr
+	print*, 'Ds lectfluxnc istdyn= ',ziadvtrac
+        print*, 'Ds lectfluxnc istphy= ',ziadvtrac2
+
+      istdyn=ziadvtrac
+      istphy=ziadvtrac2
+	
+c	pause
+
+c==================================================================
+c   Fin des initialisations
+      else ! irec=0
+c==================================================================
+
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et  physique:
+c   -----------------------------------------------------
+
+	 CALL read_fstoke0(irec,
+     .   zrec,zim,zjm,zlm,
+     .   rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,airedy,phis,
+     .   massem,pbarun,pbarvn,wn,tetan,phin)
+	
+	write(*,*) 'lectfluxnc aps read_fstoke irec',irec
+	if(physic)then
+        CALL read_pstoke0(irec,
+     .   zrec,zklon,zklev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefkz,
+     .   frac_impa,frac_nucl,yu1,yv1,ftsol,pctsrf)
+	
+	write(*,*) 'lectfluxnc aps read_pstoke irec',irec
+	
+	if (avant) then
+c Simu directe
+       do l=1,llm
+          do ig=1,klon
+             zmfu(ig,l)=mfu(ig,l)
+             zmfd(ig,l)=mfd(ig,l)
+             zde_u(ig,l)=de_u(ig,l)
+             zen_u(ig,l)=en_u(ig,l)
+             zde_d(ig,l)=de_d(ig,l)
+             zen_d(ig,l)=en_d(ig,l)
+          enddo
+       enddo
+      else
+c   Simu retro
+       do l=1,llm
+          do ig=1,klon
+             zmfd(ig,l)=-mfu(ig,l)
+             zmfu(ig,l)=-mfd(ig,l)
+             zen_d(ig,l)=de_u(ig,l)
+             zde_d(ig,l)=en_u(ig,l)
+             zen_u(ig,l)=de_d(ig,l)
+             zde_u(ig,l)=en_d(ig,l)
+          enddo
+       enddo
+      endif
+
+c-----------------------------------------------------------------------
+c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
+c-----------------------------------------------------------------------
+
+      print*,'Ap redec irec'
+	write(*,*) 'dtphys = ', dtphys
+
+         call gr_dyn_fi(llm,iip1,jjp1,klon,massem,massefi)
+
+         do ig=1,klon
+            zcontrole(ig)=1.
+         enddo
+c   zmass=(max(massem(ig,l),massem(ig,l-1))/airefi(ig)
+         do l=2,llm
+            do ig=1,klon
+               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
+               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
+               if(zflux.gt.0.9*zmass) then
+                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
+               endif
+            enddo
+         enddo
+
+         do ig=1,klon
+            if(zcontrole(ig).lt.0.99999) then
+               print*,'ATTENTION !!! on reduit les flux de masse '
+               print*,'convectifs au point ig=',ig
+            endif
+         enddo
+	
+	write(*,*) 'lectfluxnc avt gr_fi_dyn'
+
+         call gr_fi_dyn(1,klon,iip1,jjp1,zcontrole,tmpdyn)
+	
+	write(*,*) 'lectfluxnc aps gr_fi_dyn'
+        
+         do l=1,llm
+            do ig=1,klon
+               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
+               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
+               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
+               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
+               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
+               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
+            enddo
+         enddo
+	 endif
+	
+	write(*,*) 'lectfluxnc fin de boucle if'
+
+      endif ! irec=0
+
+      RETURN
+      END
+
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/minmax2.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/minmax2.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/minmax2.F	(revision 300)
@@ -0,0 +1,17 @@
+       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: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/minmax2F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/minmax2F	(revision 3)
+++ 	(revision )
@@ -1,17 +1,0 @@
-       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: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/modif_etat0.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/modif_etat0.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/modif_etat0.F	(revision 300)
@@ -0,0 +1,259 @@
+      PROGRAM modif_etat0
+      
+      USE startvar
+      USE ioipsl
+      !
+      IMPLICIT NONE
+      !
+#include "dimensions.h"
+#include "paramet.h"
+      !
+      !
+#include "dimphy.h"
+      !
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+      !
+      REAL :: latfi(klon), lonfi(klon)
+      REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1),
+     . psol(iip1, jjp1), phis(iip1, jjp1)
+      REAL :: tsol(klon,nbsrf), qsol(klon,nbsrf), sn(klon,nbsrf)
+      REAL :: evap(klon,nbsrf), albe(klon,nbsrf)
+      real :: rain_fall(klon), snow_fall(klon)
+      real :: sollw(klon), solsw(klon)
+      REAL :: radsol(klon),deltat(klon), rugmer(klon), agesno(klon)
+      REAL :: zmea(iip1*jjp1), zstd(iip1*jjp1)
+      REAL :: zsig(iip1*jjp1), zgam(iip1*jjp1), zthe(iip1*jjp1)
+      REAL :: zpic(iip1*jjp1), zval(iip1*jjp1), rugsrel(iip1*jjp1)
+      REAL :: pctsrf(klon, nbsrf)
+      REAL :: tsoil(klon, nsoilmx, nbsrf)
+      REAL :: t_ancien(klon, klev), q_ancien(klon, klev)
+      REAL :: tabcntrl0(100)
+      LOGICAL :: ancien_ok
+      ! declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itau(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+      REAL :: champint(iim, jjp1)
+      !
+      CHARACTER*80 :: varname
+      !
+#include "comdissnew.h"
+#include "control.h"
+#include "serre.h"
+#include "clesph0.h"
+
+      INTEGER  ::        longcles
+      PARAMETER      ( longcles  = 20 )
+      REAL :: clesphy0 ( longcles       )
+      REAL ::phystep,co2_ppm,solaire
+      REAL :: unskap
+      INTEGER :: radpas
+
+      CHARACTER*80 :: visu_file
+      INTEGER :: visuid
+      !
+      ! indices de boucle 
+      INTEGER :: ji
+      !   Constantes 
+      !
+      pi     = 4. * ATAN(1.)
+      rad    = 6371229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      !
+      preff     = 101325.
+      unskap = 1./kappa
+      !
+      jmp1    = jjm + 1
+      !
+      !    Construct a grid
+      !
+
+      CALL defrun_new(99,.TRUE.,clesphy0)
+
+      dtvr   = daysec/FLOAT(day_step)
+      print*,'dtvr',dtvr
+
+      CALL inicons0()
+      CALL inigeom()
+      !
+      CALL inifilr()
+      !
+      !
+      !! 1. READ orography 
+      !
+      varname = 'relief'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      orog(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0)
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Relief'
+      WRITE(*,'(49I1)') INT(orog(:,:))
+      !
+      varname = 'rugosite'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      rugo(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0)
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' 
+      WRITE(*,'(49I1)') INT(rugo(:,:)*10)
+      !
+      varname = 'masque'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      masque(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0)
+      !
+      WRITE(*,*) 'MASQUE construit : Masque'
+      WRITE(*,*) masque(:,:)
+      WRITE(*,*) 'orographie'
+      WRITE(*,*) orog(:,:)
+      !
+      !! 2. create masque and READ land iice fraction
+      !!
+      ! lit bande startphy a modifier
+      !
+     
+      CALL phyetat0("startphy.nc", phystep, co2_ppm, solaire, latfi,  
+     $    lonfi, pctsrf, tsol, tsoil, deltat, qsol, sn, 
+     $    albe, evap, rain_fall, snow_fall, solsw, sollw,
+     $    radsol, rugmer, agesno, clesphy0, 
+     $    zmea, zstd, zsig, zgam, zthe, zpic, zval, 
+     $    rugsrel, tabcntrl0, t_ancien, q_ancien, ancien_ok)
+C
+C on initialise les sous surfaces
+C
+      pctsrf=0.
+      !cree le masque a partir du fichier relief
+      varname = 'zmasq'
+      zmasq(:) = 0.
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmasq,0.0)
+      WHERE (zmasq(1 : klon) .LE. EPSFRA)
+          zmasq(1 : klon) = 0.
+      END WHERE 
+      WRITE(*,*)zmasq
+      varname = 'zmea'
+      zmea(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0)
+      varname = 'zstd'
+      zstd(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0)
+      varname = 'zsig'
+      zsig(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0)
+      varname = 'zgam'
+      zgam(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0)
+      varname = 'zthe'
+      zthe(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0)
+      varname = 'zpic'
+      zpic(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0)
+      varname = 'zval'
+      zval(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0)
+      rugsrel(:) = 0.0
+C
+C lecture du fichier glace de terre pour fixer la fraction de terre 
+C et de glace de terre
+C
+      CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp
+     $    , fid)
+      ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret)
+      ALLOCATE(dlon_lic(iml_lic), stat=iret)
+      ALLOCATE(dlat_lic(jml_lic), stat=iret)
+      ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret)
+      CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp
+     $    , lon_lic, lat_lic, lev, ttm_tmp, itau, date, dt, fid)
+      CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp
+     $    , 1, 1, fraclic)
+      CALL flinclo(fid)
+C
+C interpolation sur la grille T du modele
+C
+      WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', 
+     $    iml_lic, jml_lic
+c
+C sil les coordonnees sont en degres, on les transforme
+C
+      IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) )  THEN
+          lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180.
+      ENDIF 
+      IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN 
+          lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180.
+      ENDIF 
+
+      dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1)
+      dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) 
+C
+      CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic
+     $    ,iim, jjp1,
+     $    rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1))
+c$$$      flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1)
+      flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1)
+C
+C passage sur la grille physique
+C
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp,
+     $    pctsrf(1:klon, is_lic))
+C adequation avec le maque terre/mer
+      WHERE (pctsrf(1 : klon, is_lic) .LE. EPSFRA ) 
+          pctsrf(1 : klon, is_lic) = 0. 
+      END WHERE
+      WHERE (zmasq( 1 : klon) .LE. EPSFRA) 
+          pctsrf(1 : klon, is_lic) = 0.
+      END WHERE 
+      pctsrf(1 : klon, is_ter) = zmasq(1 : klon)
+      DO ji = 1, klon
+        IF (zmasq(ji) .GT. EPSFRA) THEN 
+            IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN
+                pctsrf(ji, is_lic) = zmasq(ji)
+                pctsrf(ji, is_ter) = 0.
+            ELSE 
+                pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic)
+            ENDIF 
+        ENDIF 
+      END DO 
+C
+C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0)
+C
+      pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon))
+      WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA)
+          pctsrf(1 : klon, is_oce) = 0.
+      END WHERE 
+C
+C verif que somme des sous surface = 1
+C
+      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+     $    .GT. EPSFRA)
+      IF (ji .NE. 0) THEN
+          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+      ENDIF 
+C
+C Ecriture etat initial physique
+C
+      WRITE(*,*)'zmasq avant phyredem'
+      WRITE(*,*) zmasq
+
+      call phyredem("restartphy.nc",phystep,radpas, co2_ppm, solaire,
+     $    latfi, lonfi, pctsrf, tsol, tsoil, deltat, qsol, sn, 
+     $    albe, evap, rain_fall, snow_fall, solsw, sollw, 
+     $    radsol, rugmer,  agesno, 
+     $    zmea, zstd, zsig, zgam, zthe, zpic, zval, rugsrel, 
+     $    t_ancien, q_ancien)
+
+      CALL histclo
+      !
+      END  
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/nudge.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/nudge.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/nudge.F	(revision 300)
@@ -0,0 +1,228 @@
+c $Header$
+      subroutine nudge(itau,ucov,vcov,teta,masse,ps)
+
+      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   ...  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 de Van-leer pour l'advection de
+c         q  , en faisant iadv = 3  dans   traceur  (29/04/97) .
+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 "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+
+
+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
+
+c   variables dynamiques pour les reanalyses.
+      REAL ucovrea1(ip1jmp1,llm),vcovrea1(ip1jm,llm) !vts cov reas
+      REAL tetarea1(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea1(ip1jmp1,llm)             ! masse
+      REAL psrea1(ip1jmp1)             ! ps
+      REAL ucovrea2(ip1jmp1,llm),vcovrea2(ip1jm,llm) !vts cov reas
+      REAL tetarea2(ip1jmp1,llm)             ! temp pot  reales
+      REAL masserea2(ip1jmp1,llm)             ! masse
+      REAL psrea2(ip1jmp1)             ! ps
+      real alphaT,alphaP,alphau,alphav
+      real dday_step,toto,reste,itau_test
+      INTEGER step_rea,count_no_rea
+
+
+c
+      INTEGER itau,ij,l
+      real ditau,tau,a
+
+      LOGICAL first
+      integer online
+      save first,online
+      data first,online/.true.,1/
+
+      save ucovrea1,vcovrea1,tetarea1,masserea1,psrea1
+      save ucovrea2,vcovrea2,tetarea2,masserea2,psrea2
+
+      save alphaT,alphau,alphav,alphaP,itau_test
+      save step_rea,count_no_rea
+
+c-----------------------------------------------------------------------
+c   initialisations pour la lecture des reanalyses.
+c    alpha determine la part des injections de donnees a chaque etape
+c    alpha=1 signifie pas d'injection
+c    alpha=0 signifie injection totale
+c-----------------------------------------------------------------------
+
+      print*,'ONLINE=',online
+      if(online.eq.-1) then
+          return
+      endif
+
+      if (first) then
+         print*
+     s   ,'1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)'
+cnec         read(*,*) online
+cnec      online=-1
+cnec     print*,'Entrer les constantes de temps de rappel en jours'
+cnec         read(*,*)alphaT
+cnec         read(*,*)alphau
+cnec         read(*,*)alphav
+cnec         read(*,*)alphaP
+             alphaT=0.1
+             alphau=0.1
+             alphav=0.1
+             alphaP=1.e10
+         print*,'alphaT,alphau,alphav,alphaP'
+     s          ,alphaT,alphau,alphav,alphaP
+         if(online.eq.-1) return
+         print*,'alpha rappel pour T, u, v, P ',
+     s    alphaT,alphau,alphav,alphaP
+c   En fait, le coef alpha qu'on utilise est
+c   x_gcm = a * x_gcm + ( 1 - a ) * x_reanalys
+c   on a alors a=1-dt/tau
+c   ou dt est la frequence a laquelle on corrige (ici iperiod*dtvr)
+c   et tau la constante de temps lue. D'ou:
+         if (online.eq.1) then
+            alphaT=1.-iperiod*dtvr/(daysec*alphaT)
+            alphau=1.-iperiod*dtvr/(daysec*alphau)
+            alphav=1.-iperiod*dtvr/(daysec*alphav)
+            alphaP=1.-iperiod*dtvr/(daysec*alphaP)
+         else
+            alphaT=0.
+            alphau=0.
+            alphav=0.
+            alphaP=0.
+c           physic=.false.
+         endif
+         print*,'alpha rappel pour T, u, v, P ',
+     s    alphaT,alphau,alphav,alphaP
+
+         itau_test=1001
+         step_rea=1
+         count_no_rea=0
+
+c    itau_test    montre si l'importation a deja ete faite au rang itau
+
+
+c   Lecture du premier etat des reanalyses.
+         call read_reanalyse(1
+     s   ,ucovrea2,vcovrea2,tetarea2,masserea2,ps,1)
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+         first=.false.
+      endif ! first
+c
+C-----------------------------------------------------------------------
+C----- IMPORTATION DES VENTS,PRESSION ET TEMPERATURE REELS:
+C-----------------------------------------------------------------------
+
+      ditau=real(itau)
+      dday_step=real(day_step)
+      write(*,*)'ditau,dday_step'
+      write(*,*)ditau,dday_step
+      toto=4*ditau/dday_step
+      reste=toto-aint(toto)
+c     write(*,*)'toto,reste',toto,reste
+
+      if (reste.eq.0.) then
+        if (itau_test.eq.itau) then
+          write(*,*)'deuxieme passage de advreel a itau=',itau
+          stop
+        else
+           CALL SCOPY( ijmllm ,vcovrea2, 1, vcovrea1 , 1 )
+           CALL SCOPY( ijp1llm,ucovrea2, 1, ucovrea1 , 1 )
+           CALL SCOPY( ijp1llm,tetarea2,1,tetarea1   , 1 )
+c          CALL SCOPY( ijp1llm,masserea2,1,masserea1   , 1 )
+c          CALL SCOPY( ip1jmp1,psrea2, 1,  psrea1, 1 )
+
+          print*,'LECTURE REANALYSES, pas ',step_rea
+     s         ,'apres ',count_no_rea,' non lectures'
+           step_rea=step_rea+1
+           itau_test=itau
+           call read_reanalyse(step_rea
+     s     ,ucovrea2,vcovrea2,tetarea2,masserea2,ps,1)
+        endif
+      else
+        count_no_rea=count_no_rea+1
+      endif
+ 
+C-----------------------------------------------------------------------
+c   Corrrections
+c
+c    x_gcm = a * x_gcm + (1-a) * x_reanalyses
+C-----------------------------------------------------------------------
+
+      ditau=real(itau)
+      dday_step=real(day_step)
+
+c     print*,'alpha1',alphaT,alphaP,alphau,alphav
+
+      tau=4*ditau/dday_step
+      tau=tau-aint(tau)
+
+      do l=1,llm
+         do ij=1,ip1jmp1
+            a=(1.-tau)*ucovrea1(ij,l)+tau*ucovrea2(ij,l)
+            ucov(ij,l)=alphau*ucov(ij,l)+(1-alphau)*a
+            a=(1.-tau)*tetarea1(ij,l)+tau*tetarea2(ij,l)
+            teta(ij,l)=alphaT*teta(ij,l)+(1-alphaT)*a
+c           a=(1.-tau)*masserea1(ij,l)+tau*masserea2(ij,l)
+c           masse(ij,l)=alphaP*masse(ij,l)+(1-alphaP)*a
+         enddo
+         do ij=1,ip1jm
+            a=(1.-tau)*vcovrea1(ij,l)+tau*vcovrea2(ij,l)
+            vcov(ij,l)=alphav*vcov(ij,l)+(1-alphav)*a
+         enddo
+      enddo
+
+c     call dump2d(iip1,jjp1,tetarea1,'TETA REA 1     ')
+c     call dump2d(iip1,jjp1,tetarea2,'TETA REA 2     ')
+c     call dump2d(iip1,jjp1,teta,'TETA           ')
+Cmaf  on ne nudge pas sur la pression de surface
+c      do ij=1,ip1jmp1
+c         a=(1.-tau)*psrea1(ij)+tau*psrea2(ij)
+c         ps(ij)=alphaP*ps(ij)+(1-alphaP)*a
+c      enddo
+
+
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/offline.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/offline.F	(revision 3)
+++ 	(revision )
@@ -1,640 +1,0 @@
-      PROGRAM offline
-      USE ioipsl
-      IMPLICIT NONE
-
-c      ......   Version  du 17/04/96    ..........
-c=======================================================================
-c
-c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
-c   -------
-c   Modif special traceur F.Forget 05/94
-c
-c   Modifs M-A Filiberti 07/99
-C
-c   Objet:
-c   ------
-c
-c   GCM LMD nouvelle grille
-c
-c=======================================================================
-
-c   ...      modification de l'integration de q ( 26/04/94 )      ....
-
-c-----------------------------------------------------------------------
-c   Declarations:
-c   -------------
-
-#include "dimensions.h"
-#include "paramet.h"
-#include "comconst.h"
-#include "comdissnew.h"
-#include "comvert.h"
-#include "comgeom2.h"
-#include "logic.h"
-#include "temps.h"
-#include "control.h"
-#include "ener.h"
-#include "description.h"
-#include "serre.h"
-#include "tracstoke.h"
-      integer ngridmx,nbsrf
-      PARAMETER (ngridmx=iim*(jjm-1)+2,nbsrf=4)
-c-----------------------------------------------------------------------
-
-      INTEGER*4  iday ! jour julien
-      REAL       time ! Heure de la journee en fraction d'1 jour
-      REAL dtdyn,dtav
-      INTEGER iday_step
-
-      INTEGER         longcles
-      PARAMETER     ( longcles = 20 )
-      REAL  clesphy0( longcles )
-      logical clefinit
-
-
-c   variables dynamiques
-      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
-      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
-      REAL pks(iip1,jjp1)                      ! exner (f pour filtre)
-      REAL phis(iip1,jjp1)                     ! geopotentiel au sol
-      REAL phi(iip1,jjp1,llm)                  ! geopotentiel
-      REAL w(iip1,jjp1,llm)                    ! vitesse verticale
-C
-C   variables physiques
-      real zmfd(ngridmx,llm),zde_d(ngridmx,llm),zen_d(ngridmx,llm)
-      REAL qfi(ngridmx,llm,nqmx)               ! champs advectes
-      real zmfu(ngridmx,llm),zde_u(ngridmx,llm),zen_u(ngridmx,llm)
-      real coefkz(ngridmx,llm)
-      real frac_impa(ngridmx,llm),frac_nucl(ngridmx,llm)
-      real pphis (ngridmx)
-      REAL airefi(ngridmx)
-      REAL latfi(ngridmx),lonfi(ngridmx) ! latitude et long pour chaque point
-      real yu1(ngridmx), yv1(ngridmx)
-      real ftsol(ngridmx,nbsrf),pctsrf(ngridmx,nbsrf)
-
-C
-      character*10 file
-
-c variables dynamiques intermediaire pour le transport
-      REAL pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) !flux de masse
-
-      REAL masse(iip1,jjp1,llm)
-      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
-      REAL teta(iip1,jjp1,llm)
-
-      INTEGER itau,irec,nrec,ldec,itauav
-      integer recmin,recmax,recstkmin,recstkmax
-      character*1 injecte,stoke
-      character*10 nom
-
-      integer jour0,isplit,nsplit_dyn,nsplit_phy,nsplit
-      logical debut,lectstart,rnpb
-
-      EXTERNAL inidissip,iniconst,inifilr
-      EXTERNAL inigeom
-      EXTERNAL exner_hyb,pression
-      EXTERNAL defrun_new
-
-      REAL time_0 ! temps de debut de simulation (% journee)
-
-      character*2 str2
-      INTEGER iq,j,i,l,nq,mode
-
-      real paprs(ngridmx,llm+1),pplay(ngridmx,llm),tempfi(ngridmx,llm)
-      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm)
-
-      real lon_stat(nqmx),lat_stat(nqmx),zlon,zlat
-      integer i_stat(nqmx),j_stat(nqmx)
-      real intensite(nqmx)
-
-      integer iqmin,iqmax
-      integer npasinject
-      data npasinject/1/
-
-      integer histid, histvid, histaveid
-      real time_step, t_wrt, t_ops
-      integer itime_step
-      character*80 dynhist_file, dynhistave_file
-
-
-      logical avant
-
-      logical debutphy,redecoupage
-      DATA debutphy/.true./
-      
-      real unskap,pksurcp,smass(iip1,jjp1)
-      integer ig0,ii,jj,iii,ij
-
-     
-      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
-      REAL ps(iip1,jjp1),pkf(ip1jmp1,llm) 
-
-
-c-----------------------------------------------------------------------
-c   Initialisations:
-c   ----------------
-
-      descript = 'Run GCM LMDZ'
-
-c-----------------------------------------------------------------------
-
-
-      rad = 6400000
-      omeg = 7.272205e-05
-      g = 9.8
-      kappa = 0.285716
-      daysec = 86400
-      cpp = 1004.70885
-Cmaf a verifier....
-      preff = 101325.
-      pa= 50000.
-C
-
-      print*,'Nombre effectif de traceurs'
-      read(*,*) nq
-      write(*,*) nq
-      print*,'Splitting du pas de temps dynamique'
-      read(*,*) nsplit_dyn
-      write(*,*) nsplit_dyn
-      print*,'Splitting du pas de temps physique'
-      read(*,*) nsplit_phy
-      write(*,*) nsplit_phy
-      print*,'jour0, par rapport au debut du fichier fluxmass'
-      read(*,*) jour0
-      write(*,*) jour0
-      print*,'redecoupage (T) ou standard (F)'
-      read(*,'(l1)') redecoupage
-      write(*,*) redecoupage
-      print*,'Lecture fichier start (T)?'
-      read(*,'(l1)') lectstart
-      write(*,'(l1)') lectstart
-      print*,'Traceurs 1 et 2 = Rn222 et Pb'
-      read(*,'(l1)') rnpb
-      write(*,'(l1)') rnpb
-      print*,'Avant T ou arriere F?'
-      read(*,'(l1)') avant
-      write(*,'(l1)') avant
-      print*,'Index min et max des traceurs a initaliser'
-      read(*,*) iqmin,iqmax
-      write(*,*) iqmin,iqmax
-      print*,'localisation (lon, lat, intensite)'
-      if(iqmax.le.0) then
-         iqmin=iqmax+1
-      endif
-      do iq=iqmin,iqmax
-         read(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
-         write(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
-      enddo
-      print*,'Injection sur combien de pas de temps'
-      read(*,*) npasinject
-      write(*,*) npasinject
-      print*,'Records min et max pour le stokage et couche '
-     s    ,'verticale (specifique reseaux), def 0 0 1'
-      read(*,*) recstkmin,recstkmax,ldec
-      write(*,*) recstkmin,recstkmax,ldec
-
-c   redefinition du splitting
-      if(mod(nsplit_dyn,nsplit_phy).eq.0) then
-         nsplit=nsplit_phy
-      elseif (mod(nsplit_phy,nsplit_dyn).eq.0) then
-         nsplit=nsplit_dyn
-      else
-         stop'prendre un des deux nsplit doit diviser l autre'
-      endif
-      nsplit_dyn=nsplit_dyn/nsplit
-      nsplit_phy=nsplit_phy/nsplit
-      print*,'nsplit,nsplit_dyn,nsplit_phy'
-     s       ,nsplit,nsplit_dyn,nsplit_phy
-c   Lecture eventuelle 
-      time_0=0.
-
-      if(nq.gt.nqmx) stop'surdimensioner nqmx'
-
-      print*,'av initial0'
-      call initial0(nq*ijp1llm,q)
-
-      print*,'av lectstart'
-      if(lectstart) then
-         CALL dynetat0("start.nc",nq,vcov,ucov,
-     .              teta,q,masse,ps,phis, time_0)
-         print*,'Lecture du start'
-      else
-         day_ini=0
-         anne_ini=0
-      endif
-      day_end=day_ini+nday
-
-
-      print*,'av defrun'
-c     open (99,file='run.def',status='old',form='formatted')
-      clefinit=.true.
-      CALL defrun_new( 99, clefinit, clesphy0 )
-c     close(99)
-
-      print*,'av iniconst'
-c   lecture du jour de demarrage
-c    premiere initialisation, eventuellement bidon
-      CALL iniconst
-      CALL inigeom
-
-C
-c  Lecture des entetes des fichiers de flux
-      if(redecoupage) then
-         call redecoupe(0,masse,pbaru,pbarv,w,teta,phi,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf,
-     s     frac_impa,frac_nucl)
-      else
-         call lectflux(0,masse,pbaru,pbarv,w,teta,phi,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf,
-     s     frac_impa,frac_nucl,phis)
-         call inigeom
-      endif
-
-c   controle sur les records
-      if(avant) then
-         recmin=2+(jour0-1)*iday_step
-         recmax=1+(jour0+nday-1)*iday_step
-      else
-         recmin=(jour0-nday)*iday_step+2
-         recmax=jour0*iday_step+1
-      endif
-      if(recmin.le.1.or.recmax.ge.nrec) then
-         print*,'Probleme de lecture '
-         print*,'recmin,recmax,nrec',recmin,recmax,nrec
-         stop
-      endif
-
-C on recalcule le nombre de pas de temps dans une journee
-c   istdyn est la frequence de stokage en "pas de temps dynamique" dans
-c   le modele on-line. dtvr est le pas de temps du meme modele en s.
-c iday-step est le nombre de lectures par jour (grand pas de temps). 
-      iday_step=daysec/(istdyn*dtvr)
-C
-      CALL iniconst
-c  on calcule le pas de temps 
-      dtvr    = daysec/FLOAT(iday_step)
-      dtphys=dtvr/(nsplit*nsplit_phy) ! a mettre apres iniconst!
-      print*,'Pas de temps physique ',dtphys
-
-
-C
-
-      call gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
-
-      print *,'Pas de temps dynamique', dtvr
-      print*,'Pas de temps physique ',dtphys
-
-c-----------------------------------------------------------------------
-C maf est ce utile ?
-
-      call suphec
-
-      CALL inifilr
-      print*,'Pas de temps physique ',dtphys
-      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
-     *                tetagdiv, tetagrot , tetatemp              )
-      print*,'Pas de temps physique ',dtphys
-
-c-----------------------------------------------------------------------
-c   temps de depart et de fin:
-c   --------------------------
-
-      itau = 0
-      iday = dayref
-      time = time_0
-         IF(time.GT.1.) THEN
-          time = time-1.
-          iday = iday+1
-         ENDIF
-      print*,'Pas de temps physique ',dtphys
-
-c=======================================================================
-c   Initialisation des fichiers de sortie
-c=======================================================================
-
-      print*,'Initialisation de wrgras'
-      file='sol'
-      call inigrads(1,iip1
-     s  ,rlonv,180./pi,-190.,190.,jjp1,rlatu,-90.,90.,180./pi
-     s  ,llm,presnivs,1.
-     s  ,dtphys,file,'gcmq2 ')
-      file='atm'
-      print*,'Pas de temps physique ',dtphys
-      call inigrads(2,iip1
-     s  ,rlonv,180./pi,-190.,190.,jjp1,rlatu,-90.,90.,180./pi
-     s  ,llm,presnivs,1.
-     s  ,dtphys,file,'gcmq2 ')
-
-      print*,'dtphys ap inigrads ',dtphys
-
-      print*,'Ecriture du fichier de conditions aux limites'
-      open (98,file='limit',form='unformatted')
-      write(98) float(im),float(jm),float(nq),float(nday)
-      write(98) (rlonv(i)*180./pi,i=1,iip1)
-      write(98) (rlatu(j)*180./pi,j=1,jjp1)
-      write(98) ((phis(i,j)/g,i=1,iip1),j=1,jjp1)
-      close(98)
-
-      CALL dynredem0("restart.nc",day_end,anne_ini,phis,nq)
-
-c-----------------------------------------------------------------------
-c   Debut de la boucle en temps:
-c   ----------------------------
-
-      do itau=1,nday*iday_step
-
-          print*,'ITAU ITAU ITAU =',itau
-         injecte='.'
-         stoke='.'
-
-c Gestion du temps
-         if (avant) then
-            dtdyn=dtvr/float(nsplit*nsplit_dyn)
-            irec=1+(jour0-1)*iday_step+itau
-         else
-            dtdyn=-dtvr/float(nsplit*nsplit_dyn)
-            irec=1+jour0*iday_step-itau+1
-         endif
-
-         debut=itau.eq.1
-
-c-----------------------------------------------------------------------
-c   Lecture des fichiers fluxmass et physique:
-c   -----------------------------------------------------
-
-         print*,'CCCCC Appel a redecoupe au pas itau=',itau
-      if(redecoupage) then
-         call redecoupe(irec,masse,pbaru,pbarv,w,teta,phi,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf, 
-     s     frac_impa,frac_nucl)
-      else
-         call lectflux(irec,masse,pbaru,pbarv,w,teta,phi,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf, 
-     s     frac_impa,frac_nucl,phis)
-      endif
-
-c    ...  ouverture du fichier de stockage netcdf ...
-C
-      IF (debut) then
-         dynhistave_file = 'dyn_hist_ave.nc'
-         day_ini=0
-         anne_ini=0
-         t_ops = periodav * daysec
-         t_wrt = periodav * daysec
-         dtav=dtvr/float(nsplit)
-         mode=1
-         CALL initdynav(dynhistave_file,day_ini,anne_ini,dtav,
-     .              t_ops, t_wrt, nq, histaveid)
-         pi=2.*asin(1.)
-         do iq=iqmin,iqmax
-            do l=1,llm
-               do j=1,jjp1
-                  do i=1,iip1
-                     q(i,j,l,iq)=0.
-                  enddo
-               enddo
-            enddo
-            zlon=lon_stat(iq)*pi/180.
-            zlat=lat_stat(iq)*pi/180.
-            CALL coordij(zlon,zlat,i_stat(iq),j_stat(iq))
-         enddo
-      ENDIF
-
-C calcul de la pression de surface.
-      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,iip1
-            ps (i,j)=smass(i,j)/aire(i,j)*g
-         end do
-      end do
-C
-C calcul de la pression et de pk (fonction d'Exner)
-C
-      CALL pression ( ip1jmp1, ap, bp, ps, p       )
-      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
-c
-C
-      do jj=1,jjp1
-         do ii=1,iip1
-           phis(ii,jj)= phi(ii,jj,1)-teta(ii,jj,1)*
-     s                             (pks(ii,jj)-pk(ii,jj,1))
-         end do
-      end do
-
-c=======================================================================
-c   TERMES SOURCES OU PUITS
-c=======================================================================
-c   terme source reparti sur npasinject pas
-c   On injecte tous les traceurs de la meme facon
-      if (itau.le.npasinject) then
-        injecte='X'
-         do iq=iqmin,iqmax
-            print*,'INJECTION AU POINT ',lon_stat(iq),lat_stat(iq)
-     s      ,'     I,J=',i_stat(iq),j_stat(iq),jjp1-j_stat(iq)+1
-            q(i_stat(iq),j_stat(iq),1,iq)=
-     s      q(i_stat(iq),j_stat(iq),1,iq)
-     s      +intensite(iq)/masse(i_stat(iq),j_stat(iq),1)/npasinject
-         enddo
-         print*,'fin des injections'
-      endif
-c=======================================================================
-c   FIN DE LA PARTIE TERMES SOURCES
-c=======================================================================
-c-----------------------------------------------------------------------
-c   Advection
-c   ----------
-
-c=======================================================================
-         do isplit=1,nsplit
-c=======================================================================
-CC MAF dans le cas du offline on ne fait pas la difference masse et massem
-            do iii=1,nsplit_dyn
-               do iq=1,nq
-                  CALL vlsplt(q(:,:,:,iq),2.,masse,w,pbaru,pbarv,dtdyn)
-               enddo
-
-c   mise à jour du champd de masse tenant compte de l'advection sur
-c   le pas de temps considere.
-
-            enddo
-
-            do iq=1,nq
-               write(str2,'(i2.2)') iq
-               if(mod(itau,1).eq.0) 
-     s         call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
-            enddo
-
-
-c-----------------------------------------------------------------------
-c   Physique  (lessivage dans phytrac maintenant) MAF
-c   ---------------------------------------------------------
-
-        if(physic) then
-         if(debut) then
-         latfi(1)=rlatu(1)*180./pi
-         lonfi(1)=0.
-         DO j=2,jjm
-            DO i=1,iim
-               latfi((j-2)*iim+1+i)= rlatu(j)*180./pi
-               lonfi((j-2)*iim+1+i)= rlonv(i)*180./pi
-            ENDDO
-         ENDDO
-         latfi(ngridmx)= rlatu(jjp1)*180./pi
-         lonfi(ngridmx)= 0.
-         endif
-
-c
-C Calcul de paprs et pplay et de temp
-c   -----------------------------------------------------------------
-c     .... paprs  definis aux (llm +1) interfaces des couches  ....
-c     .... pplay  definis aux (  llm )    milieux des couches  ....
-c   -----------------------------------------------------------------
-C
-      DO l = 1, llmp1
-        paprs( 1,l ) = p(1,1,l)
-        ig0 = 2
-          DO j = 2, jjm
-             DO i =1, iim
-              paprs( ig0,l ) = p(i,j,l)
-              ig0 = ig0 +1
-             ENDDO
-          ENDDO
-        paprs( ngridmx,l ) = p(1,jjp1,l)
-      ENDDO
-c
-      unskap   = 1./ kappa
-      DO l=1,llm
-
-         pksurcp     =  pk(1,1,l) / cpp
-         pplay(1,l)  =  preff * pksurcp ** unskap
-         tempfi(1,l)   =  teta(1,1,l) *  pksurcp
-         ig0         = 2
-
-         DO j = 2, jjm
-            DO i = 1, iim
-              pksurcp        = pk(i,j,l) / cpp
-              pplay(ig0,l)   = preff * pksurcp ** unskap
-              tempfi(ig0,l)    = teta(i,j,l)  * pksurcp
-              ig0            = ig0 + 1
-            ENDDO
-         ENDDO
-
-         pksurcp       = pk(1,jjp1,l) / cpp
-         pplay(ig0,l)  = preff * pksurcp ** unskap
-         tempfi (ig0,l)  = teta(1,jjp1,l)  * pksurcp
-      ENDDO
-c On passe le traceur et le geopot de surf  sur la grille physique
-             call gr_dyn_fi(llm*nq,iip1,jjp1,ngridmx,q,qfi)
-             call gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,pphis)
-
-             do iii=1,nsplit_phy
-C
-      print*,'dtphys avant phytrac ',dtphys
-             call phytrac(rnpb,
-     I                   ecritphy, debutphy,
-     I                   nq,
-     I                   ngridmx,llm,dtphys,
-     I                   tempfi,paprs,pplay,
-     I                   zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
-     I                   coefkz,yu1,yv1,ftsol,pctsrf,latfi,
-     I                   frac_impa, frac_nucl,
-     I                   lonfi,presnivs,airefi,pphis,
-     O                   qfi)
-C
-             debutphy= .FALSE.
-C
-             enddo ! nsplit_phy
-C
-c   On passe le traceur sur la grille dynamique.
-             call gr_fi_dyn(llm*nq,ngridmx,iip1,jjp1,qfi,q)
-
-             endif
-
-             itauav=(itau-1)*nsplit+isplit
-             CALL writedynav(histaveid, nq, itauav,vcov ,
-     ,                   ucov,teta,pk,phi,q,masse,ps,phis)
-
-         enddo ! isplit=1,nsplit
-
-         call histsync
-
-c-----------------------------------------------------------------------
-c    Calcul de ucov et vcov pour les sorties
-c   -------------------------------------
-
-         call massbar(masse, massebx, masseby )
-         do l=1,llm
-            do j=1,jjp1
-               do i=1,iip1
-               ucov(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)*cu(i,j)
-     s         /istdyn
-               enddo
-            enddo
-            do j=1,jjm
-               do i=1,iip1
-               vcov(i,j,l)=pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)*cv(i,j)
-     s         /istdyn
-               enddo
-            enddo
-         enddo
-
-         iday= dayref+itau/iday_step
-         time=
-     s   float(itau-(iday-dayref)*iday_step)/iday_step+time_0
-         IF(time.GT.1.) THEN
-            time = time-1.
-            iday = iday+1
-         ENDIF
-
-
-
-C
-c=======================================================================
-         if(irec.ge.recstkmin.and.irec.le.recstkmax) then
-            if (mod(itau,4).eq.0) then
-            stoke='X'
-               do iq=1,nq
-                  write(str2,'(i2.2)') iq
-                  nom='q'//str2
-                  call wrgrads(1,1,q(:,:,:,iq),nom,nom)
-                  call wrgrads(2,1,q(:,:,ldec,iq),nom,nom)
-               enddo
-            endif
-         endif
-
-         print*,'Record=',irec,'   stoke=',stoke,
-     s      '      injecte=',injecte
-
-      enddo ! itau
-
-      CALL dynredem1("restart.nc",0.0,
-     .          vcov,ucov,teta,q,nq,masse,ps)
-
-c=======================================================================
-C fermeture des fichiers netcdf
-          CALL histclo
-C
- 300  FORMAT('1',/,15x,'run du pas',i7,2x,'au pas',i7,2x,
-     s 'c"est a dire dujour',i7,3x,'au jour',i7,/,/)
-
-      end
-C----------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/offlinenc.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/offlinenc.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/offlinenc.F	(revision 300)
@@ -0,0 +1,948 @@
+c
+c $Header$
+c
+      PROGRAM offlinenc
+      USE ioipsl
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+      integer ngridmx,nbsrf
+      PARAMETER (ngridmx=iim*(jjm-1)+2,nbsrf=4)
+c-----------------------------------------------------------------------
+
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d'1 jour
+      REAL dtdyn,dtav
+      INTEGER iday_step
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      logical clefinit
+
+c   variables dynamiques
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
+	real qmoy(iip1,jjp1,nqmx)
+      REAL pks(iip1,jjp1)                      ! exner (f pour filtre)
+      REAL phis(iip1,jjp1)                     ! geopotentiel au sol
+      REAL phi(iip1,jjp1,llm)                  ! geopotentiel
+      REAL w(iip1,jjp1,llm)                    ! vitesse verticale
+C
+C   variables physiques
+      real zmfd(ngridmx,llm),zde_d(ngridmx,llm),zen_d(ngridmx,llm)
+      REAL qfi(ngridmx,llm,nqmx)               ! champs advectes
+      real zmfu(ngridmx,llm),zde_u(ngridmx,llm),zen_u(ngridmx,llm)
+	real t(ngridmx,llm)
+      real coefkz(ngridmx,llm)
+      real frac_impa(ngridmx,llm),frac_nucl(ngridmx,llm)
+      real pphis (ngridmx)
+      REAL airefi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx) ! latitude et long pour chaque point
+      real yu1(ngridmx), yv1(ngridmx)
+      real ftsol(ngridmx,nbsrf),pctsrf(ngridmx,nbsrf)
+C
+      character*10 file
+c variables dynamiques intermediaire pour le transport
+      REAL pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) !flux de masse
+      REAL masse(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL teta(iip1,jjp1,llm)
+      INTEGER itau,irec,nrec,ldec,itauav
+      integer recmin,recmax,recstkmin,recstkmax
+      character*1 injecte,stoke
+      character*10 nom
+
+	real tinj2,tinj1
+	integer iiinj
+      integer jour0,isplit,nsplit_dyn,nsplit_phy,nsplit
+      logical debut,lectstart,rnpb,lafin
+
+      EXTERNAL inidissip,iniconst,inifilr
+      EXTERNAL inigeom
+      EXTERNAL exner_hyb,pression
+      EXTERNAL defrun_new
+
+      REAL time_0 ! temps de debut de simulation (% journee)
+
+      character*2 str2
+      INTEGER iq,j,i,l,nq,mode
+      real paprs(ngridmx,llm+1),pplay(ngridmx,llm),tempfi(ngridmx,llm)
+      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm)
+      real lon_stat(nqmx),lat_stat(nqmx),zlon,zlat
+      integer i_stat(nqmx),j_stat(nqmx)
+      real intensite(nqmx)
+      integer iqmin,iqmax
+      integer npasinject
+      data npasinject/1/
+      integer histid, histvid, histaveid
+      real time_step, t_wrt, t_ops
+      integer itime_step
+      character*80 dynhist_file, dynhistave_file
+
+      logical avant
+      logical debutphy,redecoupage
+      DATA debutphy/.true./
+
+      real unskap,pksurcp,smass(iip1,jjp1)
+      integer ig0,ii,jj,iii,ij
+
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+      REAL ps(iip1,jjp1),pkf(ip1jmp1,llm) 
+
+	integer ntau, iinjec2,iij
+	real zttt
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+      descript = 'Run GCM LMDZ'
+	tinj1=0.
+	tinj2=0.
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+
+Cmaf a verifier....
+      preff = 101325.
+      pa= 50000.
+C
+      print*,'PARAMETRES A ENTRER DANS offline.def'
+      print*,'Nombre effectif de traceurs'
+      read(*,*) nq
+      write(*,*) nq
+      print*,'Splitting du pas de temps dynamique'
+      read(*,*) nsplit_dyn
+      write(*,*) nsplit_dyn
+      print*,'Splitting du pas de temps physique'
+      read(*,*) nsplit_phy
+      write(*,*) nsplit_phy
+      print*,'jour0, par rapport au debut du fichier fluxmass'
+      read(*,*) jour0
+      write(*,*) jour0
+      print*,'redecoupage (T) ou standard (F)'
+      read(*,'(l1)') redecoupage
+      write(*,*) redecoupage
+      print*,'Lecture fichier start (T)?'
+      read(*,'(l1)') lectstart
+      write(*,'(l1)') lectstart
+      print*,'Traceurs 1 et 2 = Rn222 et Pb'
+      read(*,'(l1)') rnpb
+      write(*,'(l1)') rnpb
+      print*,'Avant T ou arriere F?'
+      read(*,'(l1)') avant
+      write(*,'(l1)') avant
+      print*,'Index min et max des traceurs a initaliser'
+      read(*,*) iqmin,iqmax
+      write(*,*) iqmin,iqmax
+      print*,'localisation (lon, lat, intensite)'
+
+      if(iqmax.le.0) then
+         iqmin=iqmax+1
+      endif
+
+      do iq=iqmin,iqmax
+         read(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
+         write(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
+      enddo
+
+      print*,'Records min et max pour le stokage et couche '
+     s    ,'verticale (specifique reseaux), def 0 0 1'
+      read(*,*) recstkmin,recstkmax,ldec
+      write(*,*) recstkmin,recstkmax,ldec
+
+c   redefinition du splitting
+
+      if(mod(nsplit_dyn,nsplit_phy).eq.0) then
+         nsplit=nsplit_phy
+      elseif (mod(nsplit_phy,nsplit_dyn).eq.0) then
+         nsplit=nsplit_dyn
+      else
+         stop'prendre un des deux nsplit doit diviser l autre'
+      endif
+
+      nsplit_dyn=nsplit_dyn/nsplit
+      nsplit_phy=nsplit_phy/nsplit
+
+      print*,'nsplit,nsplit_dyn,nsplit_phy'
+     s       ,nsplit,nsplit_dyn,nsplit_phy
+
+c   Lecture eventuelle 
+      time_0=0.
+      if(nq.gt.nqmx) stop'surdimensioner nqmx'
+      print*,'av initial0'
+      call initial0(nq*ijp1llm,q)
+      print*,'av lectstart'
+
+      if(lectstart) then
+         CALL dynetat0("start.nc",nq,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+         print*,'Lecture du start'
+c  On zappe le radon et le plomb.
+         q(:,:,:,1)=q(:,:,:,3)
+         q(:,:,:,2)=q(:,:,:,4)
+c Initialisation d'un traceur ` 1 pour tester l'impact du lessivage.
+         q(:,:,:,3)=1.
+      else
+         day_ini=0
+         anne_ini=0
+      endif
+
+      day_end=day_ini+nday
+C      print*,'av defrun'
+c     open (99,file='run.def',status='old',form='formatted')
+      clefinit=.true.
+      CALL defrun_new( 99, clefinit, clesphy0 )
+c     close(99)
+C      print*,'av iniconst'
+c   lecture du jour de demarrage
+c    premiere cnitialisation, eventuellement bidon
+      cALL iniconst
+      CALL inigeom
+C
+      print*,'ENTREE DANS redecoupenc ou lectfluxnc
+     s        pour irec=0'
+
+c  Lecture des entetes des fichiers de flux
+
+      if(redecoupage) then
+         call redecoupenc(0,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,pphis,
+     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phis)
+      else
+         call lectfluxnc(0,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,pphis,
+     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phis)
+         call inigeom
+      endif
+
+c   controle sur les records
+
+      if(avant) then
+         recmin=2+(jour0-1)*iday_step
+         recmax=1+(jour0+nday-1)*iday_step
+      else
+         recmin=(jour0-nday)*iday_step+2
+         recmax=jour0*iday_step+1
+      endif
+
+      if(recmin.le.1.or.recmax.ge.nrec) then
+         print*,'Probleme de lecture '
+         print*,'recmin,recmax,nrec',recmin,recmax,nrec
+         stop
+      endif
+
+C on recalcule le nombre de pas de temps dans une journee
+c   istdyn est la frequence de stokage en "pas de temps dynamique" dans
+c   le modele on-line. dtvr est le pas de temps du meme modele en s.
+c iday-step est le nombre de lectures par jour (grand pas de temps). 
+
+      iday_step=daysec/(istdyn*dtvr)
+C
+      CALL iniconst
+c  on calcule le pas de temps 
+      dtvr    = daysec/FLOAT(iday_step)
+      dtphys=dtvr/(nsplit*nsplit_phy) ! a mettre apres iniconst!
+      print*,'Pas de temps physique ',dtphys
+C
+      call gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+      print *,'Pas de temps dynamique', dtvr
+      print*,'Pas de temps physique ',dtphys
+
+c-----------------------------------------------------------------------
+
+C maf est ce utile ?
+      call suphec
+      CALL inifilr
+      print*,'Pas de temps physique ',dtphys
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'Pas de temps physique ',dtphys
+
+c-----------------------------------------------------------------------
+c   temps de depart et de fin:
+c   --------------------------
+      itau = 0
+      iday = dayref
+      time = time_0
+         IF(time.GT.1.) THEN
+          time = time-1.
+          iday = iday+1
+         ENDIF
+      print*,'Pas de temps physique ',dtphys
+c=======================================================================
+c   Initialisation des fichiers de sortie
+c=======================================================================
+      print*,'Initialisation de wrgras'
+	do i=1,iip1
+	print*,'rlonu(',i,')=',rlonu(i)
+	enddo
+	do i=1,jjp1
+	print*,'rlatu(',i,')=',rlatu(i)
+	enddo
+        do i=1,iip1
+        print*,'rlonv(',i,')=',rlonv(i)
+        enddo
+        do i=1,jjm
+        print*,'rlatv(',i,')=',rlatv(i)
+        enddo
+
+      file='sol'
+      call inigrads(1,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      file='atm'
+      print*,'Pas de temps physique ',dtphys
+      call inigrads(2,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      file='pbu'
+      call inigrads(3,iip1
+     s  ,rlonu,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      file='pbv'
+      call inigrads(4,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      file='qadv'
+      call inigrads(5,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      print*,'dtphys ap inigrads ',dtphys
+
+      print*,'Ecriture du fichier de conditions aux limites'
+      open (98,file='limit',form='unformatted')
+      write(98) float(im),float(jm),float(nq),float(nday)
+      write(98) (rlonv(i)*180./pi,i=1,iip1)
+      write(98) (rlatu(j)*180./pi,j=1,jjp1)
+      write(98) ((phis(i,j)/g,i=1,iip1),j=1,jjp1)
+      close(98)
+
+      CALL dynredem0("restart.nc",day_end,anne_ini,phis,nq)
+
+c-----------------------------------------------------------------------
+c   Debut de la boucle en temps:
+c   ----------------------------
+
+      do itau=1,nday*iday_step
+          print*,'ITAU ITAU ITAU =',itau
+         injecte='.'
+         stoke='.'
+c Gestion du temps
+         if (avant) then
+            dtdyn=dtvr/float(nsplit*nsplit_dyn)
+c            irec=1+(jour0-1)*iday_step+itau
+	     irec=(jour0-1)*iday_step+itau
+         else
+            dtdyn=-dtvr/float(nsplit*nsplit_dyn)
+            irec=1+jour0*iday_step-itau+1
+         endif
+
+         debut=itau.eq.1
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et physique:
+c   -----------------------------------------------------
+         print*,'CCCCC Appel a REDECOUPENC ou LECTFLUXNC
+     s           au pas itau=',itau
+      if(redecoupage) then
+         call redecoupenc(irec,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,pphis,
+     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf, 
+     s     frac_impa,frac_nucl,phis)
+      else
+         call lectfluxnc(irec,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,pphis,
+     s     t,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf, 
+     s     frac_impa,frac_nucl,phis)
+      endif
+
+
+      print*,'TESTPHYS: ON PREND LA PUIS ',1./float(nsplit*nsplit_phy)
+     s   ,'  DES FRAC A IT=',itau
+      frac_impa(:,:)=frac_impa(:,:)**(1./float(nsplit*nsplit_phy))
+      frac_nucl(:,:)=frac_nucl(:,:)**(1./float(nsplit*nsplit_phy))
+c    ...  ouverture du fichier de stockage netcdf ...
+C
+      IF (debut) then
+         dynhistave_file = 'histmoy.nc'
+         day_ini=0
+         anne_ini=0
+         t_ops =(1./48.)*daysec
+         t_wrt =(1./48.)*daysec
+         dtav=dtvr/float(nsplit)
+         mode=1
+
+c        CALL initdynav(dynhistave_file,day_ini,anne_ini,dtav,
+c    .              t_ops, t_wrt, nq,mode, histaveid)
+
+         pi=2.*asin(1.)
+         do iq=iqmin,iqmax
+            do l=1,llm
+               do j=1,jjp1
+                  do i=1,iip1
+                     q(i,j,l,iq)=0.
+                  enddo
+               enddo
+            enddo
+
+            zlon=lon_stat(iq)*pi/180.
+            zlat=lat_stat(iq)*pi/180.
+
+            CALL coordij(zlon,zlat,i_stat(iq),j_stat(iq))
+
+         enddo
+      ENDIF
+
+C calcul de la pression de surface.
+
+      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,iip1
+            ps (i,j)=smass(i,j)/aire(i,j)*g
+         end do
+      end do
+C
+C calcul de la pression et de pk (fonction d'Exner)
+C
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+C
+      do jj=1,jjp1
+         do ii=1,iip1
+           phis(ii,jj)= phi(ii,jj,1)-teta(ii,jj,1)*
+     s                             (pks(ii,jj)-pk(ii,jj,1))
+         end do
+      end do
+c=======================================================================
+c   TERMES SOURCES OU PUITS
+         do isplit=1,nsplit
+c=======================================================================
+c injection par Fred
+c	Print*,Verifier en fct de iapp_tracvl la boucle inj
+       goto 333
+c Inj pour le stokage ttes les 0.5h
+        if (itau.gt.32.and.itau.le.56)then
+        print*,'Masse de la maille inj :',
+     s          masse(i_stat(1),j_stat(1),1)
+	do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (float(nsplit)*24.*20.)
+
+        tinj1=tinj1+intensite(1)/(float(nsplit)*24.*20.)
+	enddo
+
+           print*,'Apres injection a itau ',itau
+
+            do iq=1,nq
+               write(str2,'(i2.2)') iq
+              call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
+            enddo
+
+        print*,'QT TOTALE INJECTEE TR1',tinj1
+        print*,'fin des injections'
+
+        endif
+
+c Inj pour le stokage ttes les 1h
+
+        if (itau.gt.16.and.itau.le.28)then
+        print*,'Masse de la maille inj :',
+     s          masse(i_stat(1),j_stat(1),1)
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (float(nsplit)*12.*20.)
+
+        tinj1=tinj1+intensite(1)/(float(nsplit)*12.*20.)
+
+        enddo
+
+           print*,'Apres injection a itau ',itau
+
+            do iq=1,nq
+               write(str2,'(i2.2)') iq
+              call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
+            enddo
+
+        print*,'QT TOTALE INJECTEE TR1',tinj1
+        print*,'fin des injections'
+
+        endif
+
+c Inj pour le stokage ttes les 1.5h
+
+        if (itau.eq.11.and.isplit.gt.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.ge.12.and.itau.le.18)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.19.and.isplit.le.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+
+        endif
+
+c Inj pour le stokage ttes les 4h
+
+        if (itau.ge.5.and.itau.le.7)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+c Inj pour le stokage ttes les 3h
+
+        if (itau.eq.6.and.isplit.gt.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.ge.7.and.itau.le.9)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.10.and.isplit.le.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+c  Inj pour le stokage ttes les 6h
+
+        if (itau.eq.3.and.isplit.gt.8)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.4)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.5.and.isplit.le.8)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+c Inj sur les 4 1ere couches pour le stokage ttes les 3h
+
+        if (itau.eq.6.and.isplit.gt.2)then
+	do l=1,4
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*4.)
+	enddo
+        endif
+
+        if (itau.ge.7.and.itau.le.9)then
+	do l=1,4
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*4.)
+	enddo
+        endif
+
+        if (itau.eq.10.and.isplit.le.2)then
+        do l=1,4
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*4.)
+        enddo
+        endif
+
+c Inj pour le stokage ttes les 12h
+
+	if (itau.eq.2.and.isplit.gt.8)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.3.and.isplit.le.8)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+c Inj pour le stokage ttes les 24h
+
+        if (itau.eq.1.and.isplit.gt.32)then
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/24.
+        endif
+
+        if (itau.eq.2.and.isplit.le.8)then
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/24.
+        endif     
+
+c Inj pour le stokage ttes les 3h
+
+        if (itau.eq.6.and.isplit.gt.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.ge.7.and.itau.le.9)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+        if (itau.eq.10.and.isplit.le.2)then
+        do iiinj=1,20
+        q(i_stat(1),j_stat(1),1,1)=
+     s      q(i_stat(1),j_stat(1),1,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),1)/
+     s   (24.*20.)
+        enddo
+        endif
+
+333     continue
+
+        if (itau.eq.6.and.isplit.gt.2)then
+
+        do l=1,2
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*2.)
+        enddo
+        endif
+
+        if (itau.ge.7.and.itau.le.9)then
+        do l=1,2
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*2.)
+        enddo
+        endif
+
+        if (itau.eq.10.and.isplit.le.2)then
+        do l=1,2
+        q(i_stat(1),j_stat(1),l,1)=
+     s      q(i_stat(1),j_stat(1),l,1)
+     s  +intensite(1)/masse(i_stat(1),j_stat(1),l)/
+     s   (24.*2.)
+        enddo
+        endif
+
+c=======================================================================
+c   FIN DE LA PARTIE TERMES SOURCES
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Advection
+c   ----------
+	print*,'ENTREE DANS VLSPLT'
+c=======================================================================
+c         do isplit=1,nsplit
+c=======================================================================
+CC MAF dans le cas du offline on ne fait pas la difference masse et massem
+            do iii=1,nsplit_dyn
+		  nom='pbaru'
+                  call wrgrads(3,llm,pbaru(:,:,1),nom,nom)
+                  nom='pbarv'
+                  call wrgrads(4,llm,pbarv(:,:,1),nom,nom)
+                  nom='masse'
+                  call wrgrads(3,llm,masse(:,:,1),nom,nom)
+                  nom='w'
+                  call wrgrads(3,llm,w(:,:,1),nom,nom)
+           print*,'Entree dans vlsplt a itau et au temps',itau,time
+	   print*,'Pas advect :',dtdyn
+           print*,'Avant vlsplt'
+            do iq=1,nq
+               write(str2,'(i2.2)') iq
+              call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
+            enddo
+               do iq=1,nq
+ctest abder   CALL vlsplt(q(1,1,1,iq),2.,masse,w,pbaru,pbarv,dtdyn)
+              CALL vlsplt(q(:,:,:,iq),2.,masse,w,pbaru,pbarv,dtdyn)
+               enddo
+
+               do iq=iqmin,iqmax
+                  write(str2,'(i2.2)') iq
+                  nom='q'//str2
+                  call wrgrads(5,1,q(:,:,1,iq),nom,nom)
+               enddo
+            print*,'Apres vlsplt'
+            do iq=1,nq
+               write(str2,'(i2.2)') iq
+              call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
+            enddo
+
+c   mise a jour du champ de masse tenant compte de l'advection sur
+c   le pas de temps considere.
+
+            enddo
+
+c-----------------------------------------------------------------------
+c   Physique  (lessivage dans phytrac maintenant) MAF
+c   ---------------------------------------------------------
+        if(physic) then
+         if(debut) then
+         latfi(1)=rlatu(1)*180./pi
+         lonfi(1)=0.
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)*180./pi
+               lonfi((j-2)*iim+1+i)= rlonv(i)*180./pi
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)*180./pi
+         lonfi(ngridmx)= 0.
+         endif
+c
+C Calcul de paprs et pplay et de temp
+c   -----------------------------------------------------------------
+c     .... paprs  definis aux (llm +1) interfaces des couches  ....
+c     .... pplay  definis aux (  llm )    milieux des couches  ....
+c   -----------------------------------------------------------------
+C
+      DO l = 1, llmp1
+        paprs( 1,l ) = p(1,1,l)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              paprs( ig0,l ) = p(i,j,l)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        paprs( ngridmx,l ) = p(1,jjp1,l)
+      ENDDO
+c
+      unskap   = 1./ kappa
+      DO l=1,llm
+         pksurcp     =  pk(1,1,l) / cpp
+         pplay(1,l)  =  preff * pksurcp ** unskap
+         tempfi(1,l)   =  teta(1,1,l) *  pksurcp
+         ig0         = 2
+         DO j = 2, jjm
+            DO i = 1, iim
+              pksurcp        = pk(i,j,l) / cpp
+              pplay(ig0,l)   = preff * pksurcp ** unskap
+              tempfi(ig0,l)    = teta(i,j,l)  * pksurcp
+              ig0            = ig0 + 1
+            ENDDO
+         ENDDO
+         pksurcp       = pk(1,jjp1,l) / cpp
+         pplay(ig0,l)  = preff * pksurcp ** unskap
+         tempfi (ig0,l)  = teta(1,jjp1,l)  * pksurcp
+      ENDDO
+
+c On passe le traceur et le geopot de surf  sur la grille physique
+             call gr_dyn_fi(llm*nq,iip1,jjp1,ngridmx,q,qfi)
+c             call gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,pphis)
+             do iii=1,nsplit_phy
+C
+      lafin=.false. ! en attendant mieux.
+      print*,'dtphys avant phytrac ',dtphys
+      print*,'TESTPHYS: APPEL A PHYTRAC IT=',itau
+
+             call phytrac(rnpb,
+     I                   debutphy, lafin,
+     I                   nq,
+     I                   ngridmx,llm,dtphys,
+     I                   t,paprs,pplay,
+     I                   zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     I                   coefkz,yu1,yv1,ftsol,pctsrf,latfi,
+     I                   frac_impa, frac_nucl,
+     I                   lonfi,presnivs,airefi,pphis,
+     O                   qfi)
+C
+             debutphy= .FALSE.
+C
+             enddo ! nsplit_phy
+C
+c   On passe le traceur sur la grille dynamique.
+             call gr_fi_dyn(llm*nq,ngridmx,iip1,jjp1,qfi,q)
+
+             endif
+
+             itauav=(itau-1)*nsplit+isplit
+c             itauav=itau*nsplit+isplit
+c            CALL writedynav(histaveid, nq,mode, itauav,vcov ,
+c    ,                   ucov,teta,pk,phi,q,masse,ps,phis)
+c            qmoy(:,:,:)=qmoy(:,:,:)+q(:,:,1,:)
+         do iq=1,nq
+            do j=1,jjp1
+               do i=1,iip1
+                  qmoy(i,j,iq)=qmoy(i,j,iq)+q(i,j,1,iq)
+               enddo
+            enddo
+         enddo
+         enddo ! isplit=1,nsplit
+
+         call histsync
+
+c-----------------------------------------------------------------------
+c    Calcul de ucov et vcov pour les sorties
+c   -------------------------------------
+
+         call massbar(masse, massebx, masseby )
+         do l=1,llm
+            do j=1,jjp1
+               do i=1,iip1
+               ucov(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)*cu(i,j)
+     s         /istdyn
+               enddo
+            enddo
+
+            do j=1,jjm
+               do i=1,iip1
+               vcov(i,j,l)=pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)*cv(i,j)
+     s         /istdyn
+               enddo
+            enddo
+         enddo
+         iday= dayref+itau/iday_step
+         time=
+     s   float(itau-(iday-dayref)*iday_step)/iday_step+time_0
+         IF(time.GT.1.) THEN
+            time = time-1.
+            iday = iday+1
+         ENDIF
+C
+c=======================================================================
+               do iq=iqmin,iqmax
+                  write(str2,'(i2.2)') iq
+                  nom='q'//str2
+                  call wrgrads(1,1,qmoy(:,:,iq),nom,nom)
+                  call wrgrads(2,1,q(:,:,ldec,iq),nom,nom)
+               enddo
+
+         do iq=1,nq
+            do j=1,jjp1
+               do i=1,iip1
+                  qmoy(i,j,iq)=0.
+               enddo
+            enddo
+         enddo
+
+         print*,'Record=',irec,'   stoke=',stoke,
+     s      '      injecte=',injecte
+
+      enddo ! itau
+
+      CALL dynredem1("restart.nc",0.0,
+     .          vcov,ucov,teta,q,nq,masse,ps)
+
+c=======================================================================
+C fermeture des fichiers netcdf
+          CALL histclo
+C
+ 300  FORMAT('1',/,15x,'run du pas',i7,2x,'au pas',i7,2x,
+     s 'c"est a dire du jour',i7,3x,'au jour',i7,/,/)
+C----------------------------------------------------------------------
+
+      stop
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/paramet.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/paramet.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/paramet.h	(revision 300)
@@ -7,5 +7,6 @@
       INTEGER jcfil,jcfllm
 
-      PARAMETER( iip1= iim+1, iip2= iim+2, iip3= iim+3, jjp1= jjm+1 )
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3
+     s    ,jjp1=jjm+1-1/jjm)
       PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
       PARAMETER( kftd  = iim/2 -ndm )
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/physdem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/physdem.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/physdem.F	(revision 300)
@@ -1,95 +1,77 @@
-      subroutine physdem(lonfi, latfi,phystep,radpas,co2_ppm,
-     .                   solaire, ts, ws, 
-     .                   sn, radsol, deltat, rugmer,
-     .                   agesno, zmea, zstd, zsig,
-     .                   zgam, zthe, zpic, zval,
-     .                   rugsrel)
-
+      SUBROUTINE physdem (fichnom,dtime,radpas,co2_ppm,solaire,
+     .           rlat,rlon, pctsrf,tsol,tsoil,deltat,qsol,snow,
+     .           albedo, evap, rain_fall, snow_fall,
+     .           solsw, sollw,
+     .           radsol,frugs,agesno,
+     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,
+     .           t_ancien, q_ancien)
       IMPLICIT none
-c-------------------------------------------------------------
-C Author : L. Fairhead
-C Date   : 01/10/1999
-C Objet  : Ecriture des etats initiaux physiques
-c-------------------------------------------------------------
-c
-c
-c
-      INTEGER ivap
-      PARAMETER (ivap=1)
-c
-      REAL qsolmax
-      PARAMETER ( qsolmax = 150.0 )
-c
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ecriture de l'etat de redemarrage pour la physique
+c======================================================================
 #include "dimensions.h"
-#include "paramet.h"
-c-----------------------------------------------------------------------
-      INTEGER KIDIA, KFDIA, KLON, KLEV
-      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
-     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
-c-----------------------------------------------------------------------
-#include "comconst.h"
-#include "comvert.h"
-#include "comgeom2.h"
+#include "dimphy.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesph0.h"
 #include "control.h"
-#include "comdissnew.h"
-#include "logic.h"
-#include "ener.h"
-#include "netcdf.inc"
-c
-      INTEGER nid
-
-c Ajout de quelques parametres orographiques (F. LOTT janvier 1995)
-
-      REAL zmea(iip1,jjp1),zstd(iip1,jjp1)
-      REAL zsig(iip1,jjp1),zgam(iip1,jjp1),zthe(iip1,jjp1)
-      REAL zpic(iip1,jjp1),zval(iip1,jjp1)
-      REAL rugsrel(iip1,jjp1)
-      INTEGER idayref,anneeref
-
-
-      integer ierr, idim1, idim2, nvarid
-
-c
-      REAL phystep
+#include "temps.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
       INTEGER radpas
+      REAL rlat(klon), rlon(klon)
       REAL co2_ppm
       REAL solaire
-      REAL latfi(klon), lonfi(klon)
-      REAL champhys(klon)
-      REAL ts(klon)
+      REAL tsol(klon,nbsrf)
+      REAL tsoil(klon,nsoilmx,nbsrf)
       REAL deltat(klon)
-      REAL ws(klon)
-      REAL sn(klon)
+      REAL qsol(klon,nbsrf)
+      REAL snow(klon,nbsrf)
+      REAL albedo(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      REAL rain_fall(klon)
+      REAL snow_fall(klon)
+      real solsw(klon)
+      real sollw(klon)
       REAL radsol(klon)
-      REAL rugmer(klon)
+      REAL frugs(klon,nbsrf)
       REAL agesno(klon)
+      REAL zmea(klon)
+      REAL zstd(klon)
+      REAL zsig(klon)
+      REAL zgam(klon)
+      REAL zthe(klon)
+      REAL zpic(klon)
+      REAL zval(klon)
+      REAL rugsrel(klon)
+      REAL pctsrf(klon, nbsrf)
+      REAL t_ancien(klon,klev), q_ancien(klon,klev)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
       INTEGER length
       PARAMETER (length=100)
       REAL tab_cntrl(length)
-
-c
-
-      EXTERNAL defrun_new,iniconst,geopot,inigeom,massdair,pression
-      EXTERNAL exner_hyb , SSUM
-c
-#include "serre.h"
-#include "clesph0.h"
-#include "fxyprim.h"
-c-----------------------------------------------------------------------
-c
-c  stockage sur le fichier Physique:
-c
-      ierr = NF_CREATE("startphy.nc", NF_CLOBBER, nid)
+c
+      INTEGER isoil, nsrf
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
       IF (ierr.NE.NF_NOERR) THEN
-        WRITE(6,*)' Pb d''ouverture du fichier startphy.nc'
-        WRITE(6,*)' ierr = ', ierr
+        write(6,*)' Pb d''ouverture du fichier '//fichnom
+        write(6,*)' ierr = ', ierr
         CALL ABORT
       ENDIF
 c
       ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
-     .                       "Fichier demmarage physique")
+     .                       "Fichier redemmarage physique")
 c
       ierr = NF_DEF_DIM (nid, "index", length, idim1)
       ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2)
+      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon*klev, idim3)
 c
       ierr = NF_ENDDEF(nid)
@@ -98,34 +80,21 @@
          tab_cntrl(ierr) = 0.0
       ENDDO
-      tab_cntrl(1)  = phystep
-      tab_cntrl(2)  = radpas
-      tab_cntrl(3)  = co2_ppm
-      tab_cntrl(4)  = solaire
-      tab_cntrl(5)  = iflag_con
-      tab_cntrl(6)  = nbapp_rad
-c
-cc     Modif ( P. Le Van )
-c
-       tab_cntrl( 7 ) = 0. 
-       tab_cntrl( 8 ) = 0. 
-       tab_cntrl( 9 ) = 0. 
-       tab_cntrl(10 ) = 0. 
-       tab_cntrl(11 ) = 0. 
-       tab_cntrl(12 ) = 0. 
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
 
-      IF(  cycle_diurne )  tab_cntrl( 7 ) = 1. 
-      IF(   soil_model  )  tab_cntrl( 8 ) = 1. 
-      IF(    new_oliq   )  tab_cntrl( 9 ) = 1. 
-      IF(    ok_orodr   )  tab_cntrl(10 ) = 1. 
-      IF(    ok_orolf   )  tab_cntrl(11 ) = 1. 
-      IF(  ok_limitvrai )  tab_cntrl(12 ) = 1. 
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
 
-      tab_cntrl(13)  = dayref
-      tab_cntrl(14)  = anneeref
-
-
-cc   ***    new_oliq   (  commentaires de L. LI dans routine physique ) 
-cc   ***  ok_orodr  et ok_orolf   si on appelle l'orographie      ****
-
+      tab_cntrl(13) = dayref
+      tab_cntrl(14) = anneeref
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = anne_ini
 c
       ierr = NF_REDEF (nid)
@@ -153,9 +122,8 @@
      .                        "Longitudes de la grille physique")
       ierr = NF_ENDDEF(nid)
-
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,lonfi)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,lonfi)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon)
 #endif
 c
@@ -170,53 +138,254 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,latfi)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,latfi)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "TS", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "TS", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
-     .                        "Temperature de la surface")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ts)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,ts)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "QS", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "QS", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
-     .                        "Humidite du sol")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ws)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,ws)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "SNOW", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "SNOW", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 5,
-     .                        "Neige")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sn)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,sn)
-#endif
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat)
+#endif
+c
+C PB ajout du masque terre/mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "masque", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
+     .                        "masque terre mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmasq)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmasq)
+#endif      
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "fraction de continent")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_ter))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_ter))
+#endif
+C 
+C 2. Fraction de glace de terre
+C 
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
+     .                        "fraction glace de terre")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon,is_lic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_lic))
+#endif
+C
+C 3. fraction ocean
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "fraction ocean")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_oce))
+#endif
+C
+C 4. Fraction glace de mer
+C
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                        "fraction glace mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_sic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_sic))
+#endif
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Temperature de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol(1,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+      DO isoil=1, nsoilmx
+        IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+        WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
+     .                        "Temperature du sol No."//str7)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de couches"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf))
+#else
+        ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf))
+#endif
+      ENDDO
+      ENDDO
+c
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Ecart de la SST (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
+     .                        "Humidite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Evaporation de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
+#endif
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Neige de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf))
+#endif
+      ENDDO
+
 c
       ierr = NF_REDEF (nid)
@@ -237,31 +406,84 @@
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
-     .                        "Ecart de la SST (pour slab-ocean)")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
-     .                        "Longueur de rugosite sur mer")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer)
-#endif
+      ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Rayonnement solaire a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
+     .                        "Rayonnement IF a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "precipitation liquide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                        "precipitation solide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_DOUBLE,1,idim2,nvarid)
+#else
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
+#endif
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "rugosite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
+#endif
+      ENDDO
 c
       ierr = NF_REDEF (nid)
@@ -280,5 +502,4 @@
 #endif
 c
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zmea, champhys)
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -289,10 +510,9 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-c
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zstd, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
+#endif
+c
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -303,10 +523,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zsig, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -317,10 +535,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zgam, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -331,10 +547,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zthe, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -345,10 +559,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zpic, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -359,10 +571,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, zval, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -373,10 +583,8 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
-#endif
-
-      CALL gr_dyn_fi(1, iip1, jjp1, klon, rugsrel, champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
+#endif
       ierr = NF_REDEF (nid)
 #ifdef NC_DOUBLE
@@ -387,12 +595,37 @@
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien)
 #endif
 c
       ierr = NF_CLOSE(nid)
-
+c
       RETURN
-
       END
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/pres2lev.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/pres2lev.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/pres2lev.F	(revision 300)
@@ -0,0 +1,77 @@
+c $Header$
+c******************************************************
+      SUBROUTINE   pres2lev(varo,varn,lmo,lmn,po,pn,
+     %                      ni,nj)
+c
+c interpolation lineaire pour passer
+c a une nouvelle discretisation verticale pour
+c les variables de GCM
+c Francois Forget (01/1995)
+c 
+c MOdif remy roca 12/97 pour passer de pres2sig
+c**********************************************************
+
+      IMPLICIT NONE
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+
+       INTEGER lmo ! dimensions ancienne couches (input)
+       INTEGER lmn ! dimensions nouvelle couches (input)
+       INTEGER lmomx ! dimensions ancienne couches (input)
+       INTEGER lmnmx ! dimensions nouvelle couches (input)
+
+       parameter(lmomx=10000,lmnmx=10000)
+
+        real po(lmo)! niveau de pression en millibars
+        real pn(ni,nj,lmn) ! niveau de pression en pascals
+
+       INTEGER i,j,Nhoriz,ni,nj ! nombre de point horizontale (input)
+
+       REAL varo(ni,nj,lmo) ! var dans l'ancienne grille (input)
+       REAL varn(ni,nj,lmn) ! var dans la nouvelle grille (output)
+
+       real zvaro(lmomx),zpo(lmomx)
+
+c Autres variables
+c """"""""""""""""
+       INTEGER n, ln ,lo 
+       REAL coef
+
+c run
+c ====
+        do i=1,ni
+        do j=1,nj
+c a chaque point de grille correspond un nouveau sigma old
+c qui vaut pres(l)/ps(i,j)
+           do lo=1,lmo
+              zpo(lo)=po(lmo+1-lo)
+              zvaro(lo)=varo(i,j,lmo+1-lo)
+           enddo
+        
+           do ln=1,lmn
+              if (pn(i,j,ln).ge.zpo(1))then
+                 varn(i,j,ln) =  zvaro(1)
+              else if (pn(i,j,ln).le.zpo(lmo)) then
+                 varn(i,j,ln) =  zvaro(lmo)
+              else
+                 do lo=1,lmo-1 
+                    if ( (pn(i,j,ln).le.zpo(lo)).and.
+     &                 (pn(i,j,ln).gt.zpo(lo+1)) )then
+                       coef=(pn(i,j,ln)-zpo(lo))
+     &                 /(zpo(lo+1)-zpo(lo))
+                       varn(i,j,ln)=zvaro(lo)
+     &                 +coef*(zvaro(lo+1)-zvaro(lo))
+c       print*,'pn(',ln,')=',pn(i,j,ln),varn(i,j,ln)
+                    end if
+                 enddo           
+              endif
+           enddo
+
+        enddo
+        enddo
+      return
+      end    
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_dstoke.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_dstoke.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_dstoke.F	(revision 300)
@@ -0,0 +1,78 @@
+c $Header$
+            subroutine read_dstoke(irec,zdtvr,ziadvtrac,ziadvtrac2)
+
+
+            IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+	
+	integer ncidfd
+        save ncidfd
+        integer variddt,varididvt,varididvp
+        save variddt,varididvt,varididvp
+        real*4 dtv(1,1,1),adv2(1,1,1),adv(1,1,1)
+        real zdtvr,ziadvtrac,ziadvtrac2
+        integer status,irec
+        real rcode
+        INTEGER epais(2), debut(2)
+	
+	if (irec .eq. 0) then
+	
+	ncidfd=NCOPN('defstoke.nc',NCNOWRIT,rcode)
+
+        variddt=NCVID(ncidfd,'dtvr',rcode)
+        print*,'ncidfd,variddt',ncidfd,variddt
+
+        varididvt=NCVID(ncidfd,'istdyn',rcode)
+        print*,'ncidfd,varididvt',ncidfd,varididvt
+	
+	varididvp=NCVID(ncidfd,'istphy',rcode)
+        print*,'ncidfd,varididvp',ncidfd,varididvp
+
+c lecture de zdtvr et ziadvtrac
+	
+	epais(1) = 1
+        epais(2) = 1
+        debut(1) = 1
+        debut(2) = 1
+
+#ifdef NC_DOUBLE
+        status=NF_GET_VARA_DOUBLE(ncidfd,variddt,debut,epais,dtv)
+#else
+        status=NF_GET_VARA_REAL(ncidfd,variddt,debut,epais,dtv)
+#endif
+        zdtvr=dtv(1,1,1)
+
+#ifdef NC_DOUBLE
+        status=NF_GET_VARA_DOUBLE(ncidfd,varididvt,debut,epais,adv)
+#else
+        status=NF_GET_VARA_REAL(ncidfd,varididvt,debut,epais,adv)
+#endif
+        ziadvtrac= adv(1,1,1)
+	
+#ifdef NC_DOUBLE
+	status=NF_GET_VARA_DOUBLE(ncidfd,varididvp,debut,epais,adv2)
+#else
+	status=NF_GET_VARA_REAL(ncidfd,varididvp,debut,epais,adv2)
+#endif
+        ziadvtrac2= adv2(1,1,1)
+
+        write(*,*) 'ds read_dstoke zdtvr = ', zdtvr
+        write(*,*) 'ds read_dstoke ziadvtrac = ', ziadvtrac
+        write(*,*) 'ds read_dstoke ziadvtrac2 = ', ziadvtrac2
+	
+c           status=NF_CLOSE(ncidfd)
+
+        else
+            stop'Pas bon irec ne 0'
+	endif
+	
+	return
+
+	end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke.F	(revision 300)
@@ -0,0 +1,297 @@
+c $Header$
+	subroutine read_fstoke(irec,
+     . zrec,zim,zjm,zlm,rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,
+     . airedy,phis,
+     . masse,pbaru,pbarv,w,teta,phi)
+
+	IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+	
+      integer nlevnc,irec
+      parameter (nlevnc=19)
+      integer mode,l
+
+	integer imo,jmo,imo1,jmo1,imn,jmn
+	parameter (imn=iim,jmn=jjm,imo=imn/2,jmo=(jmn+1)/2)
+        parameter (imo1=imo+1,jmo1=jmo+1)
+
+      real*4 pbaru(imo1,jmo1,llm),pbarv(imo1,jmo,llm)
+      real*4 teta(imo1,jmo1,llm),phis(imo1,jmo1),phi(imo1,jmo1,llm)
+      real*4 masse(imo1,jmo1,llm),w(imo1,jmo1,llm)
+      real*4 airedy(imo1,jmo1)
+      real*4 rlonu_dy(imo1,jmo1),rlonv_dy(imo1,jmo),
+     . rlatu_dy(imo1,jmo1),rlatv_dy(imo1,jmo)
+      integer*4 ncrec,ncim,ncjm,nclm
+      integer*4 zrec,zim,zjm,zlm
+      integer*4 xid,yid,zid,tid
+      real*4 zdtvr,ziadvtrac
+      real adv(1), dtv(1)
+
+      integer ncidf,ncidfv
+      integer varidpu,varidpv,varidt,varidw,varidps,varidph,varidai
+      integer varidpl,varidm
+      integer varidnlo,varidnla,varidnlov,varidnlav
+      save ncidf,ncidfv
+      save varidpu,varidpv,varidt,varidw,varidps,varidph,varidai
+      save varidpl,varidm
+      save varidnlo,varidnla,varidnlov,varidnlav
+
+      real*4 pl(nlevnc)
+
+      integer start(4),count(4),status
+
+      real rcode
+	
+      character namedim	
+	
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidf=NCOPN('fluxstoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidf,'phis',rcode)
+            print*,'ncidf,varidps',ncidf,varidps
+
+            varidpl=NCVID(ncidf,'sig_s',rcode)
+            print*,'ncidf,varidpl',ncidf,varidpl
+	
+	    varidnlo=NCVID(ncidf,'nav_lon',rcode)
+            print*,'ncidf,varidnlo',ncidf,varidnlo
+          
+            varidnla=NCVID(ncidf,'nav_lat',rcode)
+            print*,'ncidf,varidnla',ncidf,varidnla
+	
+            varidai=NCVID(ncidf,'aire',rcode)
+            print*,'ncidf,varidai',ncidf,varidai
+         
+            varidm=NCVID(ncidf,'masse',rcode)
+            print*,'ncidf,varidm',ncidf,varidm
+
+            varidpu=NCVID(ncidf,'pbaru',rcode)
+            print*,'ncidf,varidpu',ncidf,varidpu
+		
+            varidw=NCVID(ncidf,'w',rcode)
+            print*,'ncidf,varidw',ncidf,varidw
+	
+	    varidt=NCVID(ncidf,'teta',rcode)
+            print*,'ncidf,varidt',ncidf,varidt
+ 
+	    varidph=NCVID(ncidf,'phi',rcode)
+            print*,'ncidf,varidph',ncidf,varidph
+	
+	    ncidfv=NCOPN('fluxstokev.nc',NCNOWRIT,rcode)
+
+            varidpv=NCVID(ncidfv,'pbarv',rcode)
+            print*,'ncidfv,varidpv',ncidfv,varidpv
+	
+	    varidnlov=NCVID(ncidfv,'nav_lon',rcode)
+            print*,'ncidf,varidnlov',ncidf,varidnlov
+          
+            varidnlav=NCVID(ncidfv,'nav_lat',rcode)
+            print*,'ncidfv,varidnlav',ncidfv,varidnlav
+	
+
+c ID pour les dimensions
+	
+	    status = nf_inq_dimid(ncidf,'y',yid)
+            status = nf_inq_dimid(ncidf,'x',xid)
+            status = nf_inq_dimid(ncidf,'sig_s',zid) 
+            status = nf_inq_dimid(ncidf,'time_counter',tid)
+
+c lecture des dimensions
+	
+	    status = nf_inq_dim(ncidf,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidf,xid,namedim,ncim)
+            status = nf_inq_dim(ncidf,zid,namedim,nclm)
+            status = nf_inq_dim(ncidf,tid,namedim,ncrec)
+	
+	    zjm=ncjm
+            zim=ncim
+            zlm=nclm
+            zrec=ncrec
+	
+	    write(*,*) 'read_fstoke : zrec = ', zrec
+            write(*,*) 'read_fstoke : zlm = ', zlm
+            write(*,*) 'read_fstoke : zim = ', zim
+            write(*,*) 'read_fstoke : zjm = ', zjm
+
+c niveaux de pression
+        
+#ifdef NC_DOUBLE
+       status=NF_GET_VARA_DOUBLE(ncidf,varidpl,1,zlm,pl)
+#else
+       status=NF_GET_VARA_REAL(ncidf,varidpl,1,zlm,pl)
+#endif
+
+c rlonu,rlonv,rlatu,rlatv
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+	
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidnlo,start,count,rlonu_dy)
+      status=NF_GET_VARA_DOUBLE(ncidf,varidnla,start,count,rlatu_dy)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidnlo,start,count,rlonu_dy)
+      status=NF_GET_VARA_REAL(ncidf,varidnla,start,count,rlatu_dy)
+#endif
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm-1
+      count(3)=1
+      count(4)=0
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidnlov,start,count,rlonv_dy)
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidnlav,start,count,rlatv_dy)
+#else
+      status=NF_GET_VARA_REAL(ncidfv,varidnlov,start,count,rlonv_dy)
+      status=NF_GET_VARA_REAL(ncidfv,varidnlav,start,count,rlatv_dy)
+#endif
+
+c Lecture de phis et aire
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidps,start,count,phis)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidps,start,count,phis)
+#endif
+
+c aire
+#ifdef NC_DOUBLE
+       status=NF_GET_VARA_DOUBLE(ncidf,varidai,start,count,airedy)
+#else
+       status=NF_GET_VARA_REAL(ncidf,varidai,start,count,airedy)
+#endif
+
+       else 
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs 
+c ---------------------
+
+      print*,'WARNING!!! Il n y a pas de test de coherence'
+      print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zlm
+      count(4)=1
+
+c masse 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidm,start,count,masse)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidm,start,count,masse)
+#endif
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jmo1*nlevnc,masse)
+	print*,'***********Lecture MASSE '
+       call dump2d(imo1,jmo1,masse,'MASSE COUCHE 1')
+c pbaru 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidpu,start,count,pbaru)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidpu,start,count,pbaru)
+#endif
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jmo1*nlevnc,pbaru)
+c      call dump2d(imo1,jmo1,pbaru,'PBARUNC COUCHE 1')
+
+c w 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidw,start,count,w)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidw,start,count,w)
+#endif
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jmo1*nlevnc,w)
+c      call dump2d(imo1,jmo1,w,'WNC COUCHE 1')
+
+c teta 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidt,start,count,teta)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidt,start,count,teta)
+#endif
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jmo1*nlevnc,teta)
+c      call dump2d(imo1,jmo1,teta,'TETANC COUCHE 1')
+
+c phi 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidph,start,count,phi)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidph,start,count,phi)
+#endif
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jmo1*nlevnc,phi)
+c      call dump2d(imo1,jmo1,phi,'PHINC COUCHE 1')
+	
+	count(2) = zjm-1 
+
+c  pbarv
+	print*,'Lecture de pbarv irec=',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidpv,start,count,pbarv)
+#else
+      status=NF_GET_VARA_REAL(ncidfv,varidpv,start,count,pbarv)
+#endif
+c      call correctbid(iim,jjm*nlevnc,pbarv)
+	PRINT*,'*******LECTURE DE PBARV******'
+      call dump2d(imo1,jjm,pbarv,'PBARVNC COUCHE 1')
+	print*,'Ok Lecture de pbarv irec=',irec
+      start(3)=irec
+      start(4)=0
+      count(2)=jmo1
+      count(3)=1
+      count(4)=0
+
+	endif
+	print*,'Fin read_fstoke a irec=',irec
+      return
+      end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke0.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke0.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_fstoke0.F	(revision 300)
@@ -0,0 +1,269 @@
+c $Header$
+	subroutine read_fstoke0(irec,
+     . zrec,zim,zjm,zlm,rlonu_dy,rlonv_dy,rlatu_dy,rlatv_dy,
+     . airedy,phis,
+     . masse,pbaru,pbarv,w,teta,phi)
+
+	IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+	
+      integer nlevnc,irec
+      parameter (nlevnc=19)
+      integer mode,l
+
+      real*4 pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real*4 teta(iip1,jjp1,llm),phis(iip1,jjp1),phi(iip1,jjp1,llm)
+      real*4 masse(iip1,jjp1,llm),w(iip1,jjp1,llm)
+      real*4 airedy(iip1,jjp1)
+      real*4 rlonu_dy(iip1,jjp1),rlonv_dy(iip1,jjm),
+     . rlatu_dy(iip1,jjp1),rlatv_dy(iip1,jjm)
+      integer*4 ncrec,ncim,ncjm,nclm
+      integer*4 zrec,zim,zjm,zlm
+      integer*4 xid,yid,zid,tid
+      real*4 zdtvr,ziadvtrac
+      real adv(1), dtv(1)
+
+      integer ncidf,ncidfv
+      integer varidpu,varidpv,varidt,varidw,varidps,varidph,varidai
+      integer varidpl,varidm
+      integer varidnlo,varidnla,varidnlov,varidnlav
+      save ncidf,ncidfv
+      save varidpu,varidpv,varidt,varidw,varidps,varidph,varidai
+      save varidpl,varidm
+      save varidnlo,varidnla,varidnlov,varidnlav
+
+      real*4 pl(nlevnc)
+
+      integer start(4),count(4),status
+
+      real rcode
+	
+      character namedim	
+	
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidf=NCOPN('fluxstoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidf,'phis',rcode)
+            print*,'ncidf,varidps',ncidf,varidps
+
+            varidpl=NCVID(ncidf,'sig_s',rcode)
+            print*,'ncidf,varidpl',ncidf,varidpl
+	
+	    varidnlo=NCVID(ncidf,'nav_lon',rcode)
+            print*,'ncidf,varidnlo',ncidf,varidnlo
+          
+            varidnla=NCVID(ncidf,'nav_lat',rcode)
+            print*,'ncidf,varidnla',ncidf,varidnla
+	
+            varidai=NCVID(ncidf,'aire',rcode)
+            print*,'ncidf,varidai',ncidf,varidai
+         
+            varidm=NCVID(ncidf,'masse',rcode)
+            print*,'ncidf,varidm',ncidf,varidm
+
+            varidpu=NCVID(ncidf,'pbaru',rcode)
+            print*,'ncidf,varidpu',ncidf,varidpu
+		
+            varidw=NCVID(ncidf,'w',rcode)
+            print*,'ncidf,varidw',ncidf,varidw
+	
+	    varidt=NCVID(ncidf,'teta',rcode)
+            print*,'ncidf,varidt',ncidf,varidt
+ 
+	    varidph=NCVID(ncidf,'phi',rcode)
+            print*,'ncidf,varidph',ncidf,varidph
+	
+	    ncidfv=NCOPN('fluxstokev.nc',NCNOWRIT,rcode)
+
+            varidpv=NCVID(ncidfv,'pbarv',rcode)
+            print*,'ncidfv,varidpv',ncidfv,varidpv
+	
+	    varidnlov=NCVID(ncidfv,'nav_lon',rcode)
+            print*,'ncidf,varidnlov',ncidf,varidnlov
+          
+            varidnlav=NCVID(ncidfv,'nav_lat',rcode)
+            print*,'ncidfv,varidnlav',ncidfv,varidnlav
+	
+
+c ID pour les dimensions
+	
+	    status = nf_inq_dimid(ncidf,'y',yid)
+            status = nf_inq_dimid(ncidf,'x',xid)
+            status = nf_inq_dimid(ncidf,'sig_s',zid) 
+            status = nf_inq_dimid(ncidf,'time_counter',tid)
+
+c lecture des dimensions
+	
+	    status = nf_inq_dim(ncidf,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidf,xid,namedim,ncim)
+            status = nf_inq_dim(ncidf,zid,namedim,nclm)
+            status = nf_inq_dim(ncidf,tid,namedim,ncrec)
+	
+	    zjm=ncjm
+            zim=ncim
+            zlm=nclm
+            zrec=ncrec
+	
+	    write(*,*) 'read_fstoke : zrec = ', zrec
+            write(*,*) 'read_fstoke : zlm = ', zlm
+            write(*,*) 'read_fstoke : zim = ', zim
+            write(*,*) 'read_fstoke : zjm = ', zjm
+
+c niveaux de pression
+        
+#ifdef NC_DOUBLE
+       status=NF_GET_VARA_DOUBLE(ncidf,varidpl,1,zlm,pl)
+#else
+       status=NF_GET_VARA_REAL(ncidf,varidpl,1,zlm,pl)
+#endif
+
+c rlonu,rlonv,rlatu,rlatv
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+	
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidnlo,start,count,rlonu_dy)
+      status=NF_GET_VARA_DOUBLE(ncidf,varidnla,start,count,rlatu_dy)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidnlo,start,count,rlonu_dy)
+      status=NF_GET_VARA_REAL(ncidf,varidnla,start,count,rlatu_dy)
+#endif
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm-1
+      count(3)=1
+      count(4)=0
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidnlov,start,count,rlonv_dy)
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidnlav,start,count,rlatv_dy)
+#else
+      status=NF_GET_VARA_REAL(ncidfv,varidnlov,start,count,rlonv_dy)
+      status=NF_GET_VARA_REAL(ncidfv,varidnlav,start,count,rlatv_dy)
+#endif
+
+c Lecture de phis et aire
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidps,start,count,phis)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidps,start,count,phis)
+#endif
+
+c aire
+#ifdef NC_DOUBLE
+       status=NF_GET_VARA_DOUBLE(ncidf,varidai,start,count,airedy)
+#else
+       status=NF_GET_VARA_REAL(ncidf,varidai,start,count,airedy)
+#endif
+
+       else 
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs 
+c ---------------------
+
+      print*,'WARNING!!! Il n y a pas de test de coherence'
+      print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zlm
+      count(4)=1
+
+c masse 
+	PRINT*,'LECTURE DE masse'
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidm,start,count,masse)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidm,start,count,masse)
+#endif
+
+c pbaru 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidpu,start,count,pbaru)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidpu,start,count,pbaru)
+#endif
+
+c w 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidw,start,count,w)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidw,start,count,w)
+#endif
+
+c teta 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidt,start,count,teta)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidt,start,count,teta)
+#endif
+
+c phi 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidf,varidph,start,count,phi)
+#else
+      status=NF_GET_VARA_REAL(ncidf,varidph,start,count,phi)
+#endif
+	
+	count(2) = zjm-1 
+
+c  pbarv
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidfv,varidpv,start,count,pbarv)
+#else
+      status=NF_GET_VARA_REAL(ncidfv,varidpv,start,count,pbarv)
+#endif
+
+      start(3)=irec
+      start(4)=0
+      count(2)=jjp1
+      count(3)=1
+      count(4)=0
+
+	endif
+
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_pstoke.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_pstoke.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_pstoke.F	(revision 300)
@@ -0,0 +1,456 @@
+	subroutine read_pstoke0(irec,
+     .   zrec,zkon,zkev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	  
+	  integer*4 kon,kev,zkon,zkev
+	  parameter(kon=iim*(jjm-1)+2,kev=llm)
+	  REAL*4 phisfi(kon)
+          REAL*4 phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
+
+          REAL*4 mfu(kon,kev), mfd(kon,kev)
+          REAL*4 en_u(kon,kev), de_u(kon,kev)
+          REAL*4 en_d(kon,kev), de_d(kon,kev)
+          REAL*4 coefh(kon,kev)
+		REAL*4 t(kon,kev)
+
+          REAL*4 mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
+          REAL*4 en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
+          REAL*4 en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
+          REAL*4 coefh2(iim,jjm+1,kev)
+		REAL*4 t2(iim,jjm+1,kev)
+
+          REAL*4 pl(kev)
+          integer irec
+          integer*4 xid,yid,zid,tid
+          integer*4 zrec,zim,zjm
+          integer*4 ncrec,nckon,nckev,ncim,ncjm
+
+          real*4 airefi(kon)
+          character namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def kon
+c dim de phis??
+
+          REAL*4 frac_impa(kon,kev), frac_nucl(kon,kev)
+          REAL*4 frac_impa2(iim,jjm+1,kev), 
+     .     frac_nucl2(iim,jjm+1,kev)
+          REAL*4 pyu1(kon), pyv1(kon)
+          REAL*4 pyu12(iim,jjm+1), pyv12(iim,jjm+1)
+          REAL*4 ftsol(kon,nbsrf)
+          REAL*4 psrf(kon,nbsrf) 
+	  REAL*4 ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
+          REAL*4 psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
+          REAL*4 ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
+     .     ftsol32(iim,jjm+1),
+     .     ftsol42(iim,jjm+1)
+          REAL*4 psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
+     .     psrf42(iim,jjm+1)
+	
+	  integer ncidp
+          save ncidp
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+		integer varidt
+          integer varidend,varidded,varidch,varidfi,varidfn
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+		save varidt
+          save varidend,varidded,varidch,varidfi,varidfn
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+		varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,nckev)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zkev=nckev
+            zim=ncim
+            zjm=ncjm
+	
+	    zkon=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : kev = ', zkev
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : kon = ', zkon
+
+c niveaux de pression
+
+#ifdef NC_DOUBLE
+            status=NF_GET_VARA_DOUBLE(ncidp,varidpl,1,kev,pl)
+#else
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
+#endif
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c 
+c phis
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+#endif
+
+
+      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
+
+c aire
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+#endif
+
+      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=kev
+      count(4)=1
+
+c frac_impa 
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
+
+c abder t
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+#endif
+
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
+
+c mfu
+
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+#endif
+
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
+
+c mfd
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
+
+c en_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
+
+c de_u 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
+
+c en_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
+
+c de_d 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+#endif
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
+
+c coefh 
+	print*,'LECTURE de coefh a irec =',irec
+#ifdef NC_DOUBLE
+       status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
+#else
+       status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+#endif
+
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+	print*,'LECTURE de yu1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+#endif
+
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
+
+c pyv1
+        print*,'LECTURE de yv1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
+
+c ftsol1
+        print*,'LECTURE de ftsol1 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+#endif
+       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
+
+c ftsol2
+        print*,'LECTURE de ftsol2 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
+
+c ftsol3
+	 print*,'LECTURE de ftsol3 a irec =',irec
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
+
+c ftsol4
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
+
+c psrf1 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
+
+c psrf2 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+#endif
+c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
+
+c psrf3 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
+
+c psrf4 
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
+#else
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+#endif
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
+	
+          do i = 1,kon
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_reanalyse.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_reanalyse.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/read_reanalyse.F	(revision 300)
@@ -0,0 +1,362 @@
+c
+c $Header$
+c
+      subroutine read_reanalyse(timestep,u,v,t,masse,ps,mode)
+
+c   mode=0 variables naturelles
+c   mode=1 variabels GCM
+
+      IMPLICIT NONE
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+
+      integer nlevnc
+      parameter (nlevnc=15)
+C pour annee 2000      parameter (nlevnc=21)
+      integer timestep,mode,l
+
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+
+      integer ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      integer varidpl
+      save ncidu,varidu,ncidv,varidv,ncidt,varidt,ncidps,varidps
+      save varidpl
+
+      real*4 unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real*4 tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+      real*4 pl(nlevnc)
+
+      integer start(4),count(4),status
+
+      real rcode
+      logical first,ncep
+      save first,ncep
+cMod 11 2 99
+       data first,ncep/.true.,.false./
+c      data first,ncep/.true.,.true./
+      print*,'ok0'
+c -----------------------------------------------------------------
+c   Initialisation de la lecture des fichiers
+c -----------------------------------------------------------------
+      if (first) then
+            ncidu=NCOPN('u.nc',NCNOWRIT,rcode)
+            varidu=NCVID(ncidu,'UWND',rcode)
+            print*,'ncidu,varidu',ncidu,varidu
+         if (ncep) then
+            varidpl=NCVID(ncidu,'LEVEL',rcode)
+         else
+            varidpl=NCVID(ncidu,'PRESSURE',rcode)
+         endif
+            print*,'ncidu,varidpl',ncidu,varidpl
+            ncidv=NCOPN('v.nc',NCNOWRIT,rcode)
+            varidv=NCVID(ncidv,'VWND',rcode)
+            print*,'ncidv,varidv',ncidv,varidv
+            ncidt=NCOPN('T.nc',NCNOWRIT,rcode)
+            varidt=NCVID(ncidt,'AIR',rcode)
+            print*,'ncidt,varidt',ncidt,varidt
+c           ncidps=NCOPN('ps.nc',NCNOWRIT,rcode)
+c           varidps=NCVID(ncidps,'SP',rcode)
+c           print*,'ncidps,varidps',ncidps,varidps
+      endif
+
+      print*,'ok1'
+c -----------------------------------------------------------------
+c   lecture des champs u, v, T, ps
+c -----------------------------------------------------------------
+
+c  niveaux de pression
+      print*,'WARNING!!! Il n y a pas de test de coherence'
+      print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidu,varidpl,1,nlevnc,pl)
+#else
+      status=NF_GET_VARA_REAL(ncidu,varidpl,1,nlevnc,pl)
+#endif
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=timestep
+
+      count(1)=iip1
+      count(2)=jjp1
+      count(3)=nlevnc
+      count(4)=1
+
+c  u
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unc)
+#else
+      status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unc)
+#endif
+      print*,'WARNING!!! Correction bidon pour palier a un '
+      print*,'probleme dans la creation des fichiers nc'
+      call correctbid(iim,jjp1*nlevnc,unc)
+c     call dump2d(iip1,jjp1,unc,'UNC COUCHE 1 ')
+c  T
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnc)
+#else
+      status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnc)
+#endif
+      call correctbid(iim,jjp1*nlevnc,tnc)
+c     call dump2d(iip1,jjp1,tnc,'TNC COUCHE 1 ')
+
+      count(2)=jjm
+c  v
+#ifdef NC_DOUBLE
+      status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnc)
+#else
+      status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnc)
+#endif
+      call correctbid(iim,jjm*nlevnc,vnc)
+c     call dump2d(iip1,jjm,vnc,'VNC COUCHE 1 ')
+
+      start(3)=timestep
+      start(4)=0
+      count(2)=jjp1
+      count(3)=1
+      count(4)=0
+c  ps
+C#ifdef NC_DOUBLE
+c     status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnc)
+C#else
+c     status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnc)
+C#endif
+c     call dump2d(iip1,jjp1,psnc,'PSNC COUCHE 1 ')
+c     call correctbid(iim,jjp1,psnc)
+
+c   Transformations
+      do l=1,nlevnc
+         pl(l)=pl(l)*100.
+      enddo
+      if(first) then
+         do l=1,nlevnc
+            print*,'PL(',l,')=',pl(l)
+         enddo
+      endif
+
+      call reanalyse2nat(nlevnc,unc,vnc,tnc,psnc,pl,u,v,t
+     s    ,ps,masse,pk)
+c     call dump2d(iip1,jjm,v,'V COUCHE 1 ')
+
+      if(mode.eq.1) call nat2gcm(u,v,t,pk,u,v,t)
+      print*,'TIMESTEP ',timestep
+      if(mode.ne.1) stop'mode pas egal 0'
+c     call dump2d(iip1,jjm,v,'VCOV COUCHE 1 ')
+
+c   Lignes introduites a une epoque pour un probleme oublie...
+c     do l=1,llm
+c        do i=1,iip1
+c           v(i,1,l)=0.
+c           v(i,jjm,l)=0.
+c        enddo
+c     enddo
+      first=.false.
+
+      return
+      end
+
+c -----------------------------------------------------------------
+      subroutine reanalyse2nat(nlevnc,unc,vnc,tnc,psnc,pl,u,v,t
+     s   ,ps,masse,pk)
+
+c -----------------------------------------------------------------
+c   Inversion Nord/sud de la grille + interpollation sur les niveaux
+c   verticaux du modele.
+c -----------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+
+      integer nlevnc
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),ps(iip1,jjp1)
+
+      real pl(nlevnc)
+      real unc(iip1,jjp1,nlevnc),vnc(iip1,jjm,nlevnc)
+      real tnc(iip1,jjp1,nlevnc),psnc(iip1,jjp1)
+
+      real zu(iip1,jjp1,llm),zv(iip1,jjm,llm)
+      real zt(iip1,jjp1,llm)
+
+      real pext(iip1,jjp1,llm)
+      real pbarx(iip1,jjp1,llm),pbary(iip1,jjm,llm)
+      real plunc(iip1,jjp1,llm),plvnc(iip1,jjm,llm)
+      real plsnc(iip1,jjp1,llm)
+
+      REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm),pks(iip1,jjp1)
+      real pkf(iip1,jjp1,llm)
+      real masse(iip1,jjp1,llm),pls(iip1,jjp1,llm)
+      real prefkap,unskap
+
+      integer i,j,l
+
+
+c -----------------------------------------------------------------
+c   calcul de la pression au milieu des couches.
+c -----------------------------------------------------------------
+
+c     do j=1,jjp1
+c        do i=1,iim
+c           ps(i,j)=psnc(i,jjp1+1-j)
+c        enddo
+c        ps(iip1,j)=ps(1,j)
+c     enddo
+
+      CALL pression( ip1jmp1, ap, bp, ps, p )
+      call massdair(p,masse)
+      CALL exner_hyb(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf)
+c    ....  Calcul de pls , pression au milieu des couches ,en Pascals
+      unskap=1./kappa
+      prefkap =  preff  ** kappa
+c     PRINT *,' Pref kappa unskap  ',preff,kappa,unskap
+      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
+
+
+
+c -----------------------------------------------------------------
+c   calcul des pressions pour les grilles u et v
+c -----------------------------------------------------------------
+
+      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,jjp1+1-j,l)=pbarx(i,j,l)/aireu(i,j)
+            plsnc(i,jjp1+1-j,l)=pls(i,j,l)
+         enddo
+      enddo
+      enddo
+      do l=1,llm
+      do j=1,jjm
+         do i=1,iip1
+            plvnc(i,jjm+1-j,l)=pbary(i,j,l)/airev(i,j)
+         enddo
+      enddo
+      enddo
+
+c -----------------------------------------------------------------
+      call pres2lev(unc,zu,nlevnc,llm,pl,plunc,iip1,jjp1)
+      call pres2lev(vnc,zv,nlevnc,llm,pl,plvnc,iip1,jjm )
+      call pres2lev(tnc,zt,nlevnc,llm,pl,plsnc,iip1,jjp1)
+
+c     call dump2d(iip1,jjp1,ps,'PS    ')
+c     call dump2d(iip1,jjp1,psu,'PS    ')
+c     call dump2d(iip1,jjm,psv,'PS    ')
+c  Inversion Nord/Sud
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               u(i,j,l)=zu(i,jjp1+1-j,l)
+               t(i,j,l)=zt(i,jjp1+1-j,l)
+            enddo
+            u(iip1,j,l)=u(1,j,l)
+            t(iip1,j,l)=t(1,j,l)
+         enddo
+      enddo
+
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               v(i,j,l)=zv(i,jjm+1-j,l)
+            enddo
+            v(iip1,j,l)=v(1,j,l)
+         enddo
+      enddo
+
+      return
+      end
+
+      subroutine nat2gcm(u,v,t,pk,ucov,vcov,teta)
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+#include "comvert.h"
+
+      real u(iip1,jjp1,llm),v(iip1,jjm,llm)
+      real t(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+
+      real ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+
+      integer i,j,l
+
+
+c   calcul de ucov et de la temperature potentielle
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iim
+               ucov(i,j,l)=u(i,j,l)*cu(i,j)
+               teta(i,j,l)=t(i,j,l)*cpp/pk(i,j,l)
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+            teta(iip1,j,l)=teta(1,j,l)
+         enddo
+         do i=1,iip1
+            ucov(i,1,l)=0.
+            ucov(i,jjp1,l)=0.
+            teta(i,1,l)=teta(1,1,l)
+            teta(i,jjp1,l)=teta(1,jjp1,l)
+         enddo
+      enddo
+
+c   calcul de ucov
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               vcov(i,j,l)=v(i,j,l)*cv(i,j)
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+
+c     call dump2d(iip1,jjp1,teta,'TETA EN BAS   ')
+c     call dump2d(iip1,jjp1,teta(1,1,llm),'TETA EN HAUT   ')
+
+      return
+      end
+      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))
+c              print*,'correction ',i,l,x(i,l),zz
+               x(i,l)=zz
+            endif
+         enddo
+      enddo
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/redecoupe.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/redecoupe.F	(revision 3)
+++ 	(revision )
@@ -1,637 +1,0 @@
-      SUBROUTINE redecoupe(irec,massemn,pbarun,pbarvn,wn,tetan,phin,
-     s     nrec,avant,airefi,
-     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
-     s     yu1,yv1,ftsol,pctsrf,
-     s     frac_impa,frac_nucl,phisn)
-
-      IMPLICIT NONE
-
-#include "dimensions.h"
-#include "paramet.h"
-
-#include "comvert.h"
-#include "comconst.h"
-#include "comgeom2.h"
-
-#include "tracstoke.h"
-
-      integer irec,nrec,i,j
-
-      integer ig,l
-      integer imo,jmo,imn,jmn,ii,jj,ig
-      parameter (imn=iim,jmn=jjm,imo=imn/2,jmo=(jmn+1)/2)
-      integer ngrido,ngridn
-      parameter(ngrido=(jmo-1)*imo+2,ngridn=(jmn-1)*imn+2)
-
-
-      INTEGER nbsrf
-      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
-
-      real zmfd(ngridn,llm),zde_d(ngridn,llm),zen_d(ngridn,llm)
-      real zmfu(ngridn,llm),zde_u(ngridn,llm),zen_u(ngridn,llm)
-      real coefkz(ngridn,llm)
-      real frac_impa(ngridn,llm),frac_nucl(ngridn,llm)
-      real yu1(ngridn), yv1(ngridn)
-      real ftsol(ngridn,nbsrf),pctsrf(ngridn,nbsrf)
-      integer imfu,imfd,ien_u,ide_u,
-     s      ien_d,ide_d,
-     s      icoefkz,izu1,izv1,
-     s      itsol,ipsf,
-     s      ilei, ilec
-      parameter(imfu=1,imfd=llm+1,ien_u=2*llm+1,ide_u=3*llm+1,
-     s      ien_d=4*llm+1,ide_d=5*llm+1,
-     s      icoefkz=6*llm+1,
-     s      ilei=7*llm+1,ilec=8*llm+1,
-     s      izu1=9*llm+1,izv1=9*llm+2,
-     s      itsol=9*llm+3,ipsf=9*llm+3+nbsrf)
-      logical avant
-
-
-      real massefi(ngridn,llm)
-
-      real massemn(imn+1,jmn+1,llm),tetan(imn+1,jmn+1,llm)
-      real pbarun(imn+1,jmn+1,llm),pbarvn(imn+1,jmn,llm)
-      real wn(imn+1,jmn+1,llm),phin(imn+1,jmn+1,llm)
-      real phisn(imn+1,jmn+1)
-
-      real massemo(imo+1,jmo+1,llm),tetao(imo+1,jmo+1,llm)
-      real pbaruo(imo+1,jmo+1,llm),pbarvo(imo+1,jmo,llm)
-      real wo(imo+1,jmo+1,llm),phio(imo+1,jmo+1,llm)
-      real phiso(imo+1,jmo+1)
-
-      real pbarvst(imo+1,jmo+1,llm)
-
-      real airefi(ngridn)
-
-      real xlecn(ngridn,9*llm+2+2*nbsrf),tmpn(imn+1,jmn+1)
-      real xleco(ngrido,9*llm+2+2*nbsrf),tmpo(imo+1,jmo+1)
-
-      real zcontrole(ngridn),zmass,tmpdyn(imn+1,jmn+1),zflux
-
-      real ziadvtrac,zrec,ziadvtrac2,zrec2
-      real zim,zjm,zlm,zklon,zklev
-
-      real zpi
-c  longitudes et latitudes lues
-      real rlonul(1:imo+1),rlatvl(1:jmo)
-      real rlonvl(1:imo+1),rlatul(1:jmo+1)
-c  longitudes et latitudes anciennes
-      real rlonuo(0:imo+1),rlatvo(0:jmo+1)
-c  longitudes et latitudes nouvelles
-      real rlonun(0:imn+1),rlatvn(0:jmn+1)
-      real aireo(imo+1,jmo+1)
-
-      integer ndecx(imo+1),ndecy(jmo+1)
-      real alphax(imn+1),alphay(jmn+1)
-      real alphaxo(imo+1)
-      real alpha(imn+1,jmn+1)
-
-      real aa,uu(0:imo+1),vv(imo+1,0:jmo+1)
-
-
-      integer iest(imo+1),iouest(imo+1)
-      integer jsud(jmo+1),jnord(jmo+1)
-
-      integer in,io,jn,jo,l,iin,jjn
-      integer i,j
-      real dlatm,dlatp,dlonm,dlonp
-
-
-      zpi=2.*asin(1.)
-
-
-c==================================================================
-c   Si le numero du record est 0 alors: INITIALISATION
-c==================================================================
-c
-      print*,'ENTREE DANS LECTFLUX'
-        print*,'IREC=',IREC
-      if(irec.eq.0) then
-
-        print*,'IREC==',0
-
-C test         call inigeom
-c==================================================================
-c   Definition des surdecoupages dans les deux directions
-c==================================================================
-
-      ndecx(1)=1
-      do io=2,imo
-         ndecx(io)=2
-      enddo
-      ndecx(imo+1)=1
-
-      ndecy(1)=1
-      do jo=2,jmo
-         ndecy(jo)=2
-      enddo
-      ndecy(jmo+1)=1
-
-      ii=0
-      do io=1,imo+1
-         ii=ii+ndecx(io)
-      enddo
-      if(ii.ne.iim) then
-         print*,'ii=',ii,'   iim=',iim
-         stop
-      endif
-
-      jj=0
-      do jo=1,jmo+1
-         jj=jj+ndecy(jo)
-      enddo
-      if(jj.ne.jjp1) then
-         print*,'jj=',jj,'   jjm=',jjm
-         stop
-      endif
-
-c==================================================================
-c   Calcul des jsud,... correspondant aux intersections des
-c   grilles.
-c==================================================================
-
-      iest(1)=0
-      do io=2,imo+1
-         iest(io)=iest(io-1)+ndecx(io-1)
-         iouest(io-1)=iest(io)
-      enddo
-      iouest(imo+1)=iest(imo+1)+ndecx(imo+1)
-
-      jnord(1)=0
-      do jo=2,jmo+1
-         jnord(jo)=jnord(jo-1)+ndecy(jo-1)
-         jsud(jo-1)=jnord(jo)
-      enddo
-      jsud(jmo+1)=jnord(jmo+1)+ndecy(jmo+1)
-
-c==================================================================
-c   ouverture des fichiers, lecture des entetes
-c==================================================================
-
-c   Fichier fluxmass
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
-#endif
-      open(47,file='fluxmass',form='unformatted',
-     s     access='direct'
-     s     ,recl=4*6*(imo+1)*(jmo+1)*llm)
-      read(47,rec=1) zrec,dtvr,ziadvtrac,zim,zjm,zlm
-     s   ,rlonul,rlonvl,rlatul,rlatvl,aireo
-     s    ,phiso
-
-      print*,'zrec,dtvr,ziadvtrac,zim,zjm,zlm'
-      print*,zrec,dtvr,ziadvtrac,zim,zjm,zlm
-      if((imo-nint(zim))*(jmo-nint(zjm)).ne.0) then
-        print*,'Modifier les dimensions dans redecoupe '
-        print*,'Mettre imo=',zim,'   jmo=',zjm
-        stop
-      endif
-
-
-c  Fichier physique
-c  Fichier lessivage (supprime les donnees utiles sont dans "physique")
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:physique")
-#endif
-      open(49,file='physique',form='unformatted',
-     s     access='direct'
-     s     ,recl=4*ngrido*(9*llm+2+2*nbsrf))
-      read(49,rec=1) zrec2,ziadvtrac2,zklon,zklev
-      print*,'Entete du fichier physique'
-      print*,zrec2,ziadvtrac2,zklon,zklev
-
-      nrec=zrec
-      istdyn=ziadvtrac
-      istphy=ziadvtrac2
-
-c==================================================================
-c   Definition des anciennes latitudes et longitudes
-c   (qui pourraient etre relues plus tard)
-c==================================================================
-
-      rlonuo(0)=-zpi
-      do io=1,imo
-c        rlonuo(io)=2.*zpi/FLOAT(imo)*(io+0.5-0.5*FLOAT(imo)-1.)
-c        print*,'LON ',io,rlonuo(io),rlonul(io)
-         rlonuo(io)=rlonul(io)
-      enddo
-      rlonuo(imo+1)=zpi
-
-      rlatvo(0)=zpi/2.
-      do jo=1,jmo
-c        rlatvo(jo)=zpi/FLOAT(jmo)*(0.5*FLOAT(jmo)+1.-jo-0.5)
-c        print*,'LAT ',jo,rlatvo(jo),rlatvl(jo)
-         rlatvo(jo)=rlatvl(jo)
-      enddo
-      rlatvo(jmo+1)=-zpi/2.
-
-c     do jo=1,jmo+1
-c        do io=1,imo+1
-c           aireo(io,jo)=rad*rad
-c    s         *(rlonuo(io)-rlonuo(io-1))
-c    s         *(sin(rlatvo(jo-1))-sin(rlatvo(jo)))
-c           aireo(io,jo)=airel(io,jo)
-c        enddo
-c        aireo(1,jo)=aireo(1,jo)+aireo(imo+1,jo)
-c        aireo(imo+1,jo)=aireo(1,jo)
-c     enddo
-
-      do io=2,imo
-         alphaxo(io)=1.
-      enddo
-      alphaxo(1)=(rlonuo(1)-rlonuo(0))
-     s        /(rlonuo(1)-rlonuo(0)+rlonuo(imo+1)-rlonuo(imo))
-      alphaxo(imo+1)=1.-alphaxo(1)
-
-c==================================================================
-c    Definition des nouvelles latitudes et longitudes
-c==================================================================
-
-      rlonun(0)=-zpi
-      do io=1,imo+1
-         do iin=1,iouest(io)-iest(io)
-            in=iin+iest(io)
-            rlonun(in)=
-     s      rlonuo(io-1)+iin*(rlonuo(io)-rlonuo(io-1))
-     s      /ndecx(io)
-            alphax(in)=alphaxo(io)/ndecx(io)
-            print787,io,rlonuo(io-1)*180./zpi,in
-     s      ,iest(io),iouest(io),rlonun(in)*180./zpi,alphax(in)
-         enddo
-      enddo
-
-      rlatvn(0)=0.5*zpi
-      do jo=1,jmo+1
-         print*,'jo=',jo
-         do jjn=1,jsud(jo)-jnord(jo)
-            jn=jnord(jo)+jjn
-            rlatvn(jn)=rlatvo(jo-1)+jjn*(rlatvo(jo)-rlatvo(jo-1))
-     s      /ndecy(jo)
-            alphay(jn)=(sin(rlatvn(jn-1))-sin(rlatvn(jn)))
-     s                /(sin(rlatvo(jo-1))-sin(rlatvo(jo)))
-            print787,jo,rlatvo(jo-1)*180./zpi,jn
-     s      ,jnord(jo),jsud(jo),rlatvn(jn)*180./zpi,alphay(jn)
-         enddo
-      enddo
-
-787   format(i5,f10.2,3(i5),2(f10.2))
-      do in=1,imn
-         rlonu(in)=rlonun(in)
-         rlonv(in)=0.5*(rlonun(in)+rlonun(in-1))
-      enddo
-      rlonv(imn+1)=rlonv(1)+2.*zpi
-      rlonu(imn+1)=rlonu(1)+2.*zpi
-
-      do jn=1,jmn
-         rlatv(jn)=rlatvn(jn)
-      enddo
-      do jn=1,jmn+1
-         rlatu(jn)=0.5*(rlatvn(jn-1)+rlatvn(jn))
-      enddo
-
-      do jn=1,jmn+1
-         do in=1,imn
-            alpha(in,jn)=alphax(in)*alphay(jn)
-         enddo
-         alpha(imn+1,jn)=0.
-      enddo
-
-c     call dump2d(iip1,jjp1,alpha,'ALPHA   ')
-
-c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
-c      .          cv( j ) = rad          * dy/dY         .
-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                             . V
-c
-c                 aireij4 .        . aireij1
-c
-c                   U .       . P      . U
-c
-c                 aireij3 .        . aireij2
-c
-c                             . V
-
-
-      do j=1,jjp1
-         do i=1,iim
-            dlonp=rlonun(i)-rlonv(i)
-            dlonm=rlonv(i)-rlonun(i-1)
-            dlatp=sin(rlatvn(j-1))-sin(rlatu(j))
-            dlatm=sin(rlatu(j))-sin(rlatvn(j))
-            aireij1 ( i,j ) = rad*rad*dlatp*dlonp
-            aireij2 ( i,j ) = rad*rad*dlatm*dlonp
-            aireij3 ( i,j ) = rad*rad*dlatm*dlonm
-            aireij4 ( i,j ) = rad*rad*dlatp*dlonm
-      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)
-           enddo
-           aireij1(iip1,j)=aireij1(1,j)
-           aireij2(iip1,j)=aireij2(1,j)
-           aireij3(iip1,j)=aireij3(1,j)
-           aireij4(iip1,j)=aireij4(1,j)
-           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)
-       enddo
-c     call dump2d(iip1,jjp1,aire,'AIRE   ')
-
-c     do jn=1,jjp1
-c        do in=1,iim
-c           aire(in,jn)=rad*rad*(sin(rlatvn(jn-1))-sin(rlatvn(jn)))
-c    s      *(rlonun(in)-rlonun(in-1))
-c           unsaire(in,jn)=1./aire(in,jn)
-c        enddo
-c        aire(iip1,jn)=aire(1,jn)
-c        unsaire(iip1,jn)=unsaire(1,jn)
-c     enddo
-c     call dump2d(iip1,jjp1,aire,'AIRE2   ')
-      DO 42 j = 1,jjp1
-      DO 41 i = 1,iim
-      unsaire(i,j) = 1./ aire(i,j)
-      aireu  (i,j) = aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
-     *                           aireij3(i+1,j)
-  41  CONTINUE
-      aireu  (iip1,j) = aireu  (1,j)
-      unsaire(iip1,j) = unsaire(1,j)
-  42  CONTINUE
-      DO 48 j = 1,jjm
-        DO i=1,iim
-         airev(i,j)     = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
-     *                           aireij4(i,j+1)
-        ENDDO
-       airev   (iip1,j) = airev(1,j)
-  48  CONTINUE
-      apoln=0.
-      apols=0.
-      do i=1,iim
-         apoln=apoln+aire(i,1)
-         apols=apols+aire(i,jjp1)
-      enddo
-
-
-
-      do jn=1,jjp1
-         do in=1,iim
-            cu(in,jn)=rad*cos(rlatu(jn))*(rlonv(in+1)-rlonv(in))
-         enddo
-         cu(iip1,jn)=cu(1,jn)
-      enddo
-      do jn=1,jjm
-         do in=1,iim+1
-            cv(in,jn)=rad*(rlatu(jn)-rlatu(jn+1))
-         enddo
-      enddo
-
-
-c==================================================================
-c   Fin des initialisations
-      else ! irec=0
-c==================================================================
-
-
-c-----------------------------------------------------------------------
-c   Lecture des fichiers fluxmass et  physique:
-c   -----------------------------------------------------
-
-c==================================================================
-c  Variables dynamiques
-c==================================================================
-
-         read(47,rec=irec) massemo,pbaruo,pbarvst,wo,tetao,phio
-        do l=1,llm
-           do j=1,jmo
-              do i=1,imo+1
-                 pbarvo(i,j,l)=pbarvst(i,j,l)
-              enddo
-           enddo
-        enddo
-
-         do l=1,llm
-            do jo=1,jmo+1
-               do io=1,imo+1
-                  do jn=jnord(jo)+1,jsud(jo)
-                     do in=iest(io)+1,iouest(io)
-                        wn(in,jn,l)=alpha(in,jn)*wo(io,jo,l)
-                        massemn(in,jn,l)=alpha(in,jn)
-     s                     *massemo(io,jo,l)
-                        tetan(in,jn,l)=tetao(io,jo,l)
-                        phin(in,jn,l)=phio(io,jo,l)
-                     enddo
-                  enddo
-               enddo
-            enddo
-            do jn=1,jmn+1
-               wn(imn+1,jn,l)=wn(1,jn,l)
-               massemn(imn+1,jn,l)=massemn(1,jn,l)
-               tetan(imn+1,jn,l)=tetan(1,jn,l)
-               phin(imn+1,jn,l)=phin(1,jn,l)
-            enddo
-         enddo
-
-         do l=1,llm
-            do jo=1,jmo+1
-               uu(imo+1)=0.5*(pbaruo(imo,jo,l)+pbaruo(imo+1,jo,l))
-               uu(0)=uu(imo+1)
-               do io=1,imo
-                  uu(io)=pbaruo(io,jo,l)
-               enddo
-               do io=1,imo+1
-                  do jn=jnord(jo)+1,jsud(jo)
-                     aa=0.
-                     do in=iest(io)+1,iouest(io)
-                        aa=aa+alphax(in)
-                        pbarun(in,jn,l)=alphay(jn)*
-     s                    (uu(io-1)+aa*(uu(io)-uu(io-1)))
-                     enddo
-                  enddo
-               enddo
-            enddo
-            do jn=1,jmn+1
-               pbarun(imn+1,jn,l)=pbarun(1,jn,l)
-            enddo
-         enddo
-
-         do l=1,llm
-            do jo=1,jmo
-               do io=1,imo+1
-                  vv(io,jo)=pbarvo(io,jo,l)
-               enddo
-            enddo
-            do io=1,imo+1
-               vv(io,0)=0.
-               vv(io,jmo+1)=0.
-            enddo
-            do jo=1,jmo+1
-               do io=1,imo+1
-                  aa=0.
-c                 do jn=jnord(jo)+1,max(jsud(jo),jmo)
-                  do jn=jnord(jo)+1,min(jsud(jo),jmn)
-                     aa=aa+alphay(jn)
-                     do in=iest(io)+1,iouest(io)
-                        pbarvn(in,jn,l)=alphax(in)*
-     s                  (vv(io,jo-1)+aa*(vv(io,jo)-vv(io,jo-1)))
-                     enddo
-                  enddo
-               enddo
-            enddo
-            do jn=1,jmn
-               pbarvn(iip1,jn,l)=pbarvn(1,jn,l)
-            enddo
-         enddo
-
-c==================================================================
-c  Variables physiques
-c==================================================================
-         read(49,rec=irec) ((xleco(ig,l),ig=1,ngrido),
-     s                                    l=1,9*llm+2+2*nbsrf)
-
-c==================================================================
-c  Passage  a la nouvelle grille
-c==================================================================
-         do l=1,9*llm+2+2*nbsrf
-c   passage aa la grille dynamique ancienne
-            do io=1,imo+1
-               tmpo(io,1)=xleco(1,l)
-               tmpo(io,jmo+1)=xleco(ngrido,l)
-            enddo
-            do jo=2,jmo
-               do io=1,imo
-                  tmpo(io,jo)=xleco((jo-2)*imo+io+1,l)
-               enddo
-               tmpo(imo+1,jo)=tmpo(1,jo)
-            enddo
-c   passage a la grillle dynamique nouvelle
-            do jo=1,jmo+1
-               do io=1,imo+1
-                  do jn=jnord(jo)+1,jsud(jo)
-                     do in=iest(io)+1,iouest(io)
-                        tmpn(in,jn)=tmpo(io,jo)
-                     enddo
-                  enddo
-               enddo
-            enddo
-c   passage a la grille physique nouvelle
-            xlecn(1,l)=tmpn(1,1)
-            xlecn(ngridn,l)=tmpn(1,jmn+1)
-            do jn=2,jmn
-               do in=1,imn
-                  xlecn((jn-2)*imn+in+1,l)=tmpn(in,jn)
-               enddo
-            enddo
-         enddo
-
-c==================================================================
-
-       do l=1,llm
-          do ig=1,ngridn
-             coefkz(ig,l)=xlecn(ig,icoefkz+l-1)
-             frac_impa(ig,l)=xlecn(ig,ilei+l-1)
-             frac_nucl(ig,l)=xlecn(ig,ilec+l-1)
-          enddo
-       enddo
-       do l=1,nbsrf
-          do ig=1,ngridn
-             ftsol(ig,l)=xlecn(ig,itsol+l-1)
-             pctsrf(ig,l)=xlecn(ig,ipsf+l-1)
-          enddo
-       enddo
-       do ig=1,ngridn
-          yv1(ig)=xlecn(ig,izv1)
-          yu1(ig)=xlecn(ig,izu1)
-       enddo
-C
-      if(avant) then
-c   Simu directe
-       do l=1,llm
-          do ig=1,ngridn
-             zmfu(ig,l)=xlecn(ig,imfu+l-1)
-             zmfd(ig,l)=xlecn(ig,imfd+l-1)
-             zde_u(ig,l)=xlecn(ig,ide_u+l-1)
-             zen_u(ig,l)=xlecn(ig,ien_u+l-1)
-             zde_d(ig,l)=xlecn(ig,ide_d+l-1)
-             zen_d(ig,l)=xlecn(ig,ien_d+l-1)
-          enddo
-       enddo
-      else
-c   Simu retro
-       do l=1,llm
-          do ig=1,ngridn
-             zmfd(ig,l)=-xlecn(ig,imfu+l-1)
-             zmfu(ig,l)=-xlecn(ig,imfd+l-1)
-             zen_d(ig,l)=xlecn(ig,ide_u+l-1)
-             zde_d(ig,l)=xlecn(ig,ien_u+l-1)
-             zen_u(ig,l)=xlecn(ig,ide_d+l-1)
-             zde_u(ig,l)=xlecn(ig,ien_d+l-1)
-          enddo
-       enddo
-      endif
-
-c-----------------------------------------------------------------------
-c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
-c-----------------------------------------------------------------------
-
-         call gr_dyn_fi(llm,iip1,jjp1,ngridn,massemn,massefi)
-
-      print*,'Ap redec irec'
-         do ig=1,ngridn
-            zcontrole(ig)=1.
-         enddo
-c   zmass=(max(massemn(ig,l),massemn(ig,l-1))/airefi(ig)
-         do l=2,llm
-            do ig=1,ngridn
-               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
-               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
-               if(zflux.gt.0.9*zmass) then
-                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
-               endif
-            enddo
-         enddo
-
-         do ig=1,ngridn
-            if(zcontrole(ig).lt.0.99999) then
-               print*,'ATTENTION !!! on reduit les flux de masse '
-               print*,'convectifs au point ig=',ig
-            endif
-         enddo
-
-         call gr_fi_dyn(1,ngridn,iip1,jjp1,zcontrole,tmpdyn)
-
-         do l=1,llm
-            do ig=1,ngridn
-               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
-               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
-               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
-               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
-               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
-               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
-            enddo
-         enddo
-
-
-      endif ! irec=0
-
-
-      RETURN
-      END
-
-
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/redecoupenc.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/redecoupenc.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/redecoupenc.F	(revision 300)
@@ -0,0 +1,1186 @@
+c
+c $Header$
+c
+      SUBROUTINE redecoupenc
+     s     (irec,massemn,pbarun,pbarvn,wn,tetan,phin,
+     s     nrec,avant,airefin,phisfin,
+     s     tn,zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkzn,
+     s     yu1n,yv1n,ftsoln,pctsrfn,
+     s     frac_impan,frac_nucln,phisn)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "tracstoke.h"
+#include "logic.h"
+
+      integer irec,nrec,i,j
+      integer ig,l
+      integer imo,jmo,imn,jmn,ii,jj,ig
+      parameter (imn=iim,jmn=jjm,imo=imn/2,jmo=(jmn+1)/2)
+      integer ngrido,ngridn
+      parameter(ngrido=(jmo-1)*imo+2,ngridn=(jmn-1)*imn+2)
+      real zdtvr
+
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+
+      real zmfd(ngridn,llm),zde_d(ngridn,llm),zen_d(ngridn,llm)
+      real zmfu(ngridn,llm),zde_u(ngridn,llm),zen_u(ngridn,llm)
+	
+       logical avant
+
+      real massefi(ngridn,llm)
+
+      real massemn(imn+1,jmn+1,llm),tetan(imn+1,jmn+1,llm)
+      real pbarun(imn+1,jmn+1,llm),pbarvn(imn+1,jmn,llm)
+      real wn(imn+1,jmn+1,llm),phin(imn+1,jmn+1,llm)
+      real phisn(imn+1,jmn+1)
+
+      real massemo(imo+1,jmo+1,llm),tetao(imo+1,jmo+1,llm)
+      real pbaruo(imo+1,jmo+1,llm),pbarvo(imo+1,jmo,llm)
+      real wo(imo+1,jmo+1,llm),phio(imo+1,jmo+1,llm)
+      real phiso(imo+1,jmo+1)
+
+      real pbarvst(imo+1,jmo+1,llm)
+
+      real tmpo2(imo+1,jmo+1,llm),tmpo1(imo,jmo+1,llm)
+      real tmpo4(imo+1,jmo+1,nbsrf),tmpo3(imo,jmo+1,nbsrf)
+      real tmpo6(imo+1,jmo+1),tmpo5(imo,jmo+1)
+      real tmpn6(imn+1,jmn+1),tmpn5(imn,jmn+1)
+      real tmpn2(imn+1,jmn+1,llm),tmpn1(imn,jmn+1,llm)
+      real tmpn4(imn+1,jmn+1,nbsrf),tmpn3(imn,jmn+1,nbsrf)
+
+	real airefio(ngrido),phisfio(ngrido),
+     .    mfuo(ngrido,llm),mfdo(ngrido,llm),en_uo(ngrido,llm),
+     .    de_uo(ngrido,llm),en_do(ngrido,llm),
+     .    de_do(ngrido,llm),coefkzo(ngrido,llm),
+     .    frac_impao(ngrido,llm),frac_nuclo(ngrido,llm),
+     .    yu1o(ngrido),yv1o(ngrido),ftsolo(ngrido,nbsrf),
+     .    pctsrfo(ngrido,nbsrf),to(ngrido,llm) 
+
+      real airefin(ngridn),phisfin(ngridn),
+     .    mfun(ngridn,llm),en_un(ngridn,llm),mfdn(ngridn,llm),
+     .    de_un(ngridn,llm),en_dn(ngridn,llm),
+     .    de_dn(ngridn,llm),coefkzn(ngridn,llm),
+     .    frac_impan(ngridn,llm),frac_nucln(ngridn,llm),
+     .    ftsoln(ngridn,nbsrf),yu1n(ngridn),yv1n(ngridn),
+     .    pctsrfn(ngridn,nbsrf),tn(ngridn,llm)
+
+      real zcontrole(ngridn),zmass,tmpdyn(imn+1,jmn+1),zflux
+
+      real ziadvtrac,ziadvtrac2,zrec2
+      integer zim,zjm,zlm,zklon,zklev,zrec
+
+      real zpi
+
+c  longitudes et latitudes lues
+      real rlonul(imo+1,jmo+1),rlatvl(imo+1,jmo)
+      real rlonvl(imo+1,jmo),rlatul(imo+1,jmo+1)
+c  longitudes et latitudes anciennes
+      real rlonuo(0:imo+1),rlatvo(0:jmo+1)
+      real rlonvo(0:imo+1),rlatuo(0:jmo+1)
+c  longitudes et latitudes nouvelles
+      real rlonun(0:imn+1),rlatvn(0:jmn+1)
+      real rlonvn(0:imn+1),rlatun(0:jmn+1)
+      real aireo(imo+1,jmo+1)
+
+      integer ndecx(imo+1),ndecy(jmo+1)
+      real alphax(imn+1),alphay(jmn+1)
+      real alphaxo(imo+1)
+      real alpha(imn+1,jmn+1)
+       real alphat(imn+1,jmn+1,llm)
+      real aa,uu(0:imo+1),vv(imo+1,0:jmo+1)
+
+
+      integer iest(imo+1),iouest(imo+1)
+      integer jsud(jmo+1),jnord(jmo+1)
+
+      integer in,io,jn,jo,l,iin,jjn
+      integer i,j
+      real dlatm,dlatp,dlonm,dlonp
+c abd
+       character*10 file
+       character*10 nom
+       character*2 str2
+c fin ab
+      zpi=2.*asin(1.)
+
+
+c==================================================================
+c   Si le numero du record est 0 alors: INITIALISATION
+c==================================================================
+c
+      print*,'ENTREE DANS LECTFLUX'
+        print*,'IREC=',IREC
+      if(irec.eq.0) then
+
+        print*,'IREC==',0
+
+C test         call inigeom
+c==================================================================
+c   Definition des surdecoupages dans les deux directions
+c==================================================================
+
+      ndecx(1)=1
+      do io=2,imo
+         ndecx(io)=2
+      enddo
+      ndecx(imo+1)=1
+
+      ndecy(1)=1
+      do jo=2,jmo
+         ndecy(jo)=2
+      enddo
+      ndecy(jmo+1)=1
+
+      ii=0
+      do io=1,imo+1
+         ii=ii+ndecx(io)
+      enddo
+      if(ii.ne.iim) then
+         print*,'ii=',ii,'   iim=',iim
+         stop
+      endif
+
+      jj=0
+      do jo=1,jmo+1
+         jj=jj+ndecy(jo)
+      enddo
+      if(jj.ne.jjp1) then
+         print*,'jj=',jj,'   jjm=',jjm
+         stop
+      endif
+
+c==================================================================
+c   Calcul des jsud,... correspondant aux intersections des
+c   grilles.
+c==================================================================
+
+      iest(1)=0
+	print*,'iest(1)=0'
+      do io=2,imo+1
+         iest(io)=iest(io-1)+ndecx(io-1)
+         iouest(io-1)=iest(io)
+	print*,'iest(',io,')=',iest(io),'iouest('
+     s              ,io-1,')=',iouest(io-1)
+	
+      enddo
+      iouest(imo+1)=iest(imo+1)+ndecx(imo+1)
+	print*,'iouest(',imo+1,')=',iouest(imo+1)
+
+      jnord(1)=0
+	print*,'jnord(1)=0'
+      do jo=2,jmo+1
+         jnord(jo)=jnord(jo-1)+ndecy(jo-1)
+         jsud(jo-1)=jnord(jo)
+        print*,'jnord(',jo,')=',jnord(jo),'jsud('
+     s              ,jo-1,')=',jsud(jo-1)
+      enddo
+      jsud(jmo+1)=jnord(jmo+1)+ndecy(jmo+1)
+	        print*,'jsud(',jmo+1,')=',jsud(jmo+1)
+
+c==================================================================
+c   ouverture des fichiers, lecture des entetes
+c==================================================================
+	
+	CALL read_dstoke(0,zdtvr,ziadvtrac,ziadvtrac2)
+
+        CALL read_fstoke(0,
+     .   zrec,zim,zjm,zlm,
+     .   rlonul,rlonvl,rlatul,rlatvl,aireo,phiso,
+     .   massemo,pbaruo,pbarvo,wo,tetao,phio)
+      
+      print*,'zrec,zdtvr,ziadvtrac,zim,zjm,zlm'
+      print*,zrec,zdtvr,ziadvtrac,zim,zjm,zlm
+
+      nrec=zrec
+      dtvr=zdtvr
+      istdyn=ziadvtrac
+      istphy=ziadvtrac2
+
+      print*,'rlonul '
+      do io=1,imo+1
+         print*,io,rlonul(io,1)
+      enddo
+	print*,'rlonvl '
+      do io=1,imo+1
+         print*,io,rlonvl(io,1)
+      enddo
+	print*,'rlatul '
+      do jo=1,jmo+1
+         print*,jo,rlatul(1,jo)
+      enddo
+	print*,'rlatvl'
+      do jo=1,jmo
+         print*,jo,rlatvl(1,jo)
+      enddo
+      
+c      if((imo-nint(zim))*(jmo-nint(zjm)).ne.0) then
+c        print*,'Modifier les dimensions dans redecoupe '
+c        print*,'Mettre imo=',zim,'   jmo=',zjm
+c  abderr      stop
+c      endif
+
+c abderrahmane
+	if(physic)then
+	CALL read_pstoke(0,
+     .   zrec,zklon,zklev,airefio,phisfio,
+     .   to,mfuo,mfdo,en_uo,de_uo,en_do,de_do,coefkzo,
+     .   frac_impao,frac_nuclo,yu1o,yv1o,ftsolo,pctsrfo)
+	
+	print*,'Entete du fichier physique'
+        print*,zrec,zklon,zklev
+	endif
+
+
+c==================================================================
+c   Definition des anciennes latitudes et longitudes
+c   (qui pourraient etre relues plus tard)
+c==================================================================
+
+
+      do io=1,imo
+         rlonuo(io)=rlonul(io,1)*zpi/180.
+	print*,'LON ',io,rlonuo(io)*180./zpi
+      enddo
+c abderr
+      rlonuo(imo+1)=0.5*(rlonul(imo,1)+rlonul(imo+1,1))*zpi/180.
+      print*,'LON ',imo+1,rlonuo(imo+1)*180./zpi
+      rlonuo(0)=rlonuo(imo+1)-2.*zpi
+      print*,'LON ',0,rlonuo(0)*180./zpi
+
+c abder
+c ATTENTION A REVOIR
+c	goto 22
+      do io=1,imo
+         rlonvo(io)=rlonvl(io,1)*zpi/180.
+        print*,'LON ',io,rlonvo(io)*180./zpi
+      enddo
+      rlonvo(imo+1)=0.5*(rlonvl(imo,1)+rlonvl(imo+1,1))*zpi/180.
+      print*,'LON ',imo+1,rlonvo(imo+1)*180./zpi
+      rlonvo(0)=rlonvo(imo+1)-2.*zpi
+      print*,'LON ',0,rlonvo(0)*180./zpi
+22    continue
+c fin ab
+
+      rlatvo(0)=zpi/2.
+      print*,'LAT ',0,rlatvo(0)*180./zpi
+      do jo=1,jmo
+        rlatvo(jo)=rlatvl(1,jo)*zpi/180.
+	print*,'LAT ',jo,rlatvo(jo)*180./zpi
+      enddo
+	rlatvo(jmo+1)=-zpi/2.
+	print*,'LAT ',jmo+1,rlatvo(jmo+1)*180./zpi
+c abd
+c ATTENTION A REVOIR
+c	goto 33
+c      rlatuo(0)=zpi/2.
+c      print*,'LAT ',0,rlatuo(0)*180./zpi
+      do jo=1,jmo+1
+        rlatuo(jo-1)=rlatul(1,jo)*zpi/180.
+        print*,'LAT ',jo-1,rlatuo(jo-1)*180./zpi
+      enddo
+        rlatuo(jmo+1)=-zpi/2.
+        print*,'LAT ',jmo+1,rlatuo(jmo+1)*180./zpi
+33    continue
+c abd
+
+      do io=2,imo
+         alphaxo(io)=1.
+      enddo
+      alphaxo(1)=(rlonuo(1)-rlonuo(0))
+     s        /(rlonuo(1)-rlonuo(0)+rlonuo(imo+1)-rlonuo(imo))
+      alphaxo(imo+1)=1.-alphaxo(1)
+
+c==================================================================
+c    Definition des nouvelles latitudes et longitudes
+c==================================================================
+
+c Nouvelles longitudes rlonun
+      rlonun(0)=rlonuo(0)
+      do io=1,imo+1
+         do iin=1,iouest(io)-iest(io)
+            in=iin+iest(io)
+            rlonun(in)=
+     s      rlonuo(io-1)+iin*(rlonuo(io)-rlonuo(io-1))
+     s      /ndecx(io)
+            alphax(in)=alphaxo(io)/ndecx(io)
+            print787,io,rlonuo(io-1)*180./zpi,in
+     s  ,iest(io),iouest(io),rlonun(in)*180./zpi,alphax(in)
+         enddo
+      enddo
+
+c Nouvelles longitudes rlonvn
+c	goto 44
+      rlonvn(0)=rlonvo(0)
+      do io=1,imo+1
+         do iin=1,iouest(io)-iest(io)
+            in=iin+iest(io)
+            rlonvn(in)=
+     s      rlonvo(io-1)+iin*(rlonvo(io)-rlonvo(io-1))
+     s      /ndecx(io)
+            alphax(in)=alphaxo(io)/ndecx(io)
+            print787,io,rlonvo(io-1)*180./zpi,in
+     s  ,iest(io),iouest(io),rlonvn(in)*180./zpi,alphax(in)
+         enddo
+      enddo
+44    continue
+
+c Nouvelles latitudes rlatvn
+      rlatvn(0)=0.5*zpi
+      do jo=1,jmo+1
+         do jjn=1,jsud(jo)-jnord(jo)
+            jn=jnord(jo)+jjn
+            rlatvn(jn)=
+     s      rlatvo(jo-1)+jjn*(rlatvo(jo)-rlatvo(jo-1))
+     s      /ndecy(jo)
+            alphay(jn)=(sin(rlatvn(jn-1))-sin(rlatvn(jn)))
+     s                /(sin(rlatvo(jo-1))-sin(rlatvo(jo)))
+           print*,jn,rlatvn(jn)*180./zpi
+         enddo
+      enddo
+
+c Nouvelles latitudes rlatun
+c	goto 55
+      rlatun(0)=0.5*zpi
+      do jo=1,jmo+1
+         do jjn=1,jsud(jo)-jnord(jo)
+            jn=jnord(jo)+jjn
+            rlatun(jn)=
+     s      rlatuo(jo-1)+jjn*(rlatuo(jo)-rlatuo(jo-1))
+     s      /ndecy(jo)
+           print*,jn,rlatvn(jn)*180./zpi
+         enddo
+      enddo
+55    continue
+
+787   format(i5,f10.2,3(i5),2(f12.6))
+      do in=1,imn
+         rlonu(in)=rlonun(in)
+         rlonv(in)=0.5*(rlonun(in)+rlonun(in-1))
+      enddo
+      rlonv(imn+1)=rlonv(1)+2.*zpi
+      rlonu(imn+1)=rlonu(1)+2.*zpi
+
+      do jn=1,jmn
+         rlatv(jn)=rlatvn(jn)
+      enddo
+      do jn=1,jmn+1
+         rlatu(jn)=0.5*(rlatvn(jn-1)+rlatvn(jn))
+      enddo
+
+      do jn=1,jmn+1
+         do in=1,imn
+            alpha(in,jn)=alphax(in)*alphay(jn)
+	    alphat(in,jn,1)=alpha(in,jn)
+         enddo
+         alpha(imn+1,jn)=0.
+	 alphat(imn+1,jn,1)=0.
+      enddo
+c abderr 19 4 00
+	do l=2,llm
+	 do jn=1,jmn+1
+         do in=1,imn+1
+	  alphat(in,jn,l)=alphat(in,jn,1)
+         enddo
+	 enddo
+        enddo
+c     call dump2d(iip1,jjp1,alpha,'ALPHA   ')
+
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+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                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+
+
+      do j=1,jjp1
+         do i=1,iim
+            dlonp=rlonun(i)-rlonv(i)
+            dlonm=rlonv(i)-rlonun(i-1)
+            dlatp=sin(rlatvn(j-1))-sin(rlatu(j))
+            dlatm=sin(rlatu(j))-sin(rlatvn(j))
+            aireij1 ( i,j ) = rad*rad*dlatp*dlonp
+            aireij2 ( i,j ) = rad*rad*dlatm*dlonp
+            aireij3 ( i,j ) = rad*rad*dlatm*dlonm
+            aireij4 ( i,j ) = rad*rad*dlatp*dlonm
+      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)
+           enddo
+           aireij1(iip1,j)=aireij1(1,j)
+           aireij2(iip1,j)=aireij2(1,j)
+           aireij3(iip1,j)=aireij3(1,j)
+           aireij4(iip1,j)=aireij4(1,j)
+           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)
+       enddo
+c     call dump2d(iip1,jjp1,aire,'AIRE   ')
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      unsaire(i,j) = 1./ aire(i,j)
+      aireu  (i,j) = aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                           aireij3(i+1,j)
+  41  CONTINUE
+      aireu  (iip1,j) = aireu  (1,j)
+      unsaire(iip1,j) = unsaire(1,j)
+  42  CONTINUE
+      DO 48 j = 1,jjm
+        DO i=1,iim
+         airev(i,j)     = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+       airev   (iip1,j) = airev(1,j)
+  48  CONTINUE
+      apoln=0.
+      apols=0.
+      do i=1,iim
+         apoln=apoln+aire(i,1)
+         apols=apols+aire(i,jjp1)
+      enddo
+
+
+
+      do jn=1,jjp1
+         do in=1,iim
+            cu(in,jn)=rad*cos(rlatu(jn))*(rlonv(in+1)-rlonv(in))
+         enddo
+         cu(iip1,jn)=cu(1,jn)
+      enddo
+      do jn=1,jjm
+         do in=1,iim+1
+            cv(in,jn)=rad*(rlatu(jn)-rlatu(jn+1))
+         enddo
+      enddo
+	Print*,'Fin irec=0'
+	go to 435
+      file='pbur'
+      call inigrads(11,iip1
+     s  ,rlonu,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,1800.,file,'gcmq2 ')
+      file='pbvr'
+      call inigrads(12,iip1
+     s  ,rlonv,180./pi,-180.,180.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,1800.,file,'gcmq2 ')
+435   continue
+c==================================================================
+c   Fin des initialisations
+      else ! irec=0
+c==================================================================
+
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et  physique:
+c   -----------------------------------------------------
+	print*,'Entrer dans read_fstoke a irec=',irec
+	CALL read_fstoke(irec,
+     .   zrec,zim,zjm,zlm,
+     .   rlonul,rlonvl,rlatul,rlatvl,aireo,phiso,
+     .   massemo,pbaruo,pbarvo,wo,tetao,phio)
+
+	print*,'Apres read_fstoke a irec=',irec
+
+c	do l=1,llm
+c           do j=1,jmo
+c              do i=1,imo+1
+c                 pbarvo(i,j,l)=pbarvst(i,j,l)
+c              enddo
+c           enddo
+c        enddo
+
+         do l=1,llm
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+c                        wn(in,jn,l)=alpha(in,jn)*wo(io,jo,l)
+c                        massemn(in,jn,l)=alpha(in,jn)
+		       wn(in,jn,l)=alphat(in,jn,l)*wo(io,jo,l)
+		       massemn(in,jn,l)=alphat(in,jn,l)
+     s                                *massemo(io,jo,l)
+                        tetan(in,jn,l)=tetao(io,jo,l)
+                        phin(in,jn,l)=phio(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               wn(imn+1,jn,l)=wn(1,jn,l)
+               massemn(imn+1,jn,l)=massemn(1,jn,l)
+               tetan(imn+1,jn,l)=tetan(1,jn,l)
+               phin(imn+1,jn,l)=phin(1,jn,l)
+            enddo
+         enddo
+c Test massemn
+	print*,'MASSE DANS LA NOUVELLE GRILLE'
+	goto 908
+	do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+	print*,'massemn(',in,jn,1,')=',massemn(in,jn,1)
+        	     enddo
+                  enddo
+               enddo
+	enddo
+	do jn=1,jmn+1
+	print*,'massemn(',imn+1,jn,1,')=',massemn(imn+1,jn,1)
+        enddo
+908     continue
+	print*,'Fin calcul de massemn pour nouv. gril.'
+         do l=1,llm
+            do jo=1,jmo+1
+               uu(imo+1)=0.5*(pbaruo(imo,jo,l)+pbaruo(imo+1,jo,l))
+               uu(0)=uu(imo+1)
+               do io=1,imo
+                  uu(io)=pbaruo(io,jo,l)
+               enddo
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     aa=0.
+                     do in=iest(io)+1,iouest(io)
+                        aa=aa+alphax(in)
+                        pbarun(in,jn,l)=alphay(jn)*
+     s                    (uu(io-1)+aa*(uu(io)-uu(io-1)))
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               pbarun(imn+1,jn,l)=pbarun(1,jn,l)
+            enddo
+         enddo
+	print*,'Fin calcul de pbarun'
+	
+	do l=1,llm
+            do jo=1,jmo
+               do io=1,imo+1
+                  vv(io,jo)=pbarvo(io,jo,l)
+               enddo
+            enddo
+            do io=1,imo+1
+               vv(io,0)=0.
+               vv(io,jmo+1)=0.
+            enddo
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  aa=0.
+c                 do jn=jnord(jo)+1,max(jsud(jo),jmo)
+                  do jn=jnord(jo)+1,min(jsud(jo),jmn)
+                     aa=aa+alphay(jn)
+                     do in=iest(io)+1,iouest(io)
+                        pbarvn(in,jn,l)=alphax(in)*
+     s                  (vv(io,jo-1)+aa*(vv(io,jo)-vv(io,jo-1)))
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn
+               pbarvn(iip1,jn,l)=pbarvn(1,jn,l)
+            enddo
+         enddo
+
+c abd
+	go to 456
+ 	nom='pbaru'
+        call wrgrads(11,llm,pbarun(:,:,1),nom,nom)
+        nom='pbarv'
+        call wrgrads(12,llm,pbarvn(:,:,1),nom,nom)
+        nom='masse'
+        call wrgrads(11,llm,massemn(:,:,1),nom,nom)
+        nom='w'
+        call wrgrads(11,llm,wn(:,:,1),nom,nom)
+456	continue
+c fin ab
+
+	if(physic)then
+        CALL read_pstoke(irec,
+     .   zrec,zklon,zklev,airefio,phisfio,
+     .   to,mfuo,mfdo,en_uo,de_uo,en_do,de_do,coefkzo,
+     .   frac_impao,frac_nuclo,yu1o,yv1o,ftsolo,pctsrfo)
+       	print*,'OK read_pstoke pour irec=',irec
+c==================================================================
+c  Passage  a la nouvelle grille
+c==================================================================
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,to,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=to(1,l)
+                tmpo2(imo+1,jmo+1,l)=to(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,tn)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+
+	call gr_fi_ecrit(llm,ngrido,imo,jmo+1,mfuo,tmpo1)
+	do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+		tmpo2(imo+1,1,l)=mfuo(1,l)
+                tmpo2(imo+1,jmo+1,l)=mfuo(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+		tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+	enddo
+	call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,mfun)
+	call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+	call initial0(llm*imo*(jmo+1),tmpo1)
+	call initial0(llm*imn*(jmn+1),tmpn1)
+	call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,mfdo,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=mfdo(1,l)
+                tmpo2(imo+1,jmo+1,l)=mfdo(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,mfdn)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,en_uo,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=en_uo(1,l)
+                tmpo2(imo+1,jmo+1,l)=en_uo(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,en_un)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,en_do,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=en_do(1,l)
+                tmpo2(imo+1,jmo+1,l)=en_do(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,en_dn)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,de_do,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=de_do(1,l)
+                tmpo2(imo+1,jmo+1,l)=de_do(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,de_dn)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,de_uo,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=de_uo(1,l)
+                tmpo2(imo+1,jmo+1,l)=de_uo(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,de_un)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,coefkzo,tmpo1)
+	do l=1,llm
+	   do jo=1,jmo+1
+	      do io=1,imo
+		tmpo2(io,jo,l)=tmpo1(io,jo,l)
+	      enddo
+	   enddo
+
+           tmpo2(imo+1,1,l)=coefkzo(1,l)
+           tmpo2(imo+1,jmo+1,l)=coefkzo(ngrido,l)
+
+           do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo2(1,jo,l)
+           enddo
+	enddo
+	      
+c   passage a la grillle dynamique nouvelle
+	do l=1,llm	
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,coefkzn)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,frac_impao,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=frac_impao(1,l)
+                tmpo2(imo+1,jmo+1,l)=frac_impao(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,frac_impan)
+        call initial0(llm*(imo+1)*(jmo+1),tmpo2)
+        call initial0(llm*imo*(jmo+1),tmpo1)
+        call initial0(llm*imn*(jmn+1),tmpn1)
+        call initial0(llm*(imn+1)*(jmn+1),tmpn2)
+        call gr_fi_ecrit(llm,ngrido,imo,jmo+1,frac_nuclo,tmpo1)
+        do l=1,llm
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo2(io,jo,l)=tmpo1(io,jo,l)
+              enddo
+           enddo
+
+                tmpo2(imo+1,1,l)=frac_nuclo(1,l)
+                tmpo2(imo+1,jmo+1,l)=frac_nuclo(ngrido,l)
+            do jo=2,jmo
+                tmpo2(imo+1,jo,l)=tmpo1(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn2(in,jn,l)=tmpo2(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn1(in,jn,l)=tmpn2(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(llm,ngridn,imn,jmn+1,tmpn1,frac_nucln)
+
+        call gr_fi_ecrit(nbsrf,ngrido,imo,jmo+1,ftsolo,tmpo3)
+        do l=1,nbsrf
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo4(io,jo,l)=tmpo3(io,jo,l)
+              enddo
+           enddo
+
+                tmpo4(imo+1,1,l)=ftsolo(1,l)
+                tmpo4(imo+1,jmo+1,l)=ftsolo(ngrido,l)
+            do jo=2,jmo
+                tmpo4(imo+1,jo,l)=tmpo3(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn4(in,jn,l)=tmpo3(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn3(in,jn,l)=tmpn4(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(nbsrf,ngridn,imn,jmn+1,tmpn3,ftsoln)
+
+        call initial0(nbsrf*(imo+1)*(jmo+1),tmpo4)
+        call initial0(nbsrf*imo*(jmo+1),tmpo3)
+        call initial0(nbsrf*imn*(jmn+1),tmpn3)
+        call initial0(nbsrf*(imn+1)*(jmn+1),tmpn4)
+        call gr_fi_ecrit(nbsrf,ngrido,imo,jmo+1,pctsrfo,tmpo3)
+        do l=1,nbsrf
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo4(io,jo,l)=tmpo3(io,jo,l)
+              enddo
+           enddo
+
+                tmpo4(imo+1,1,l)=pctsrfo(1,l)
+                tmpo4(imo+1,jmo+1,l)=pctsrfo(ngrido,l)
+            do jo=2,jmo
+                tmpo4(imo+1,jo,l)=tmpo3(1,jo,l)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn4(in,jn,l)=tmpo3(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn3(in,jn,l)=tmpn4(in,jn,l)
+               enddo
+            enddo
+        enddo
+        call gr_ecrit_fi(nbsrf,ngridn,imn,jmn+1,tmpn3,pctsrfn)
+
+        call gr_fi_ecrit(1,ngrido,imo,jmo+1,yv1o,tmpo5)
+
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo6(io,jo)=tmpo5(io,jo)
+              enddo
+           enddo
+
+                tmpo6(imo+1,1)=yv1o(1)
+                tmpo6(imo+1,jmo+1)=yv1o(ngrido)
+            do jo=2,jmo
+                tmpo6(imo+1,jo)=tmpo5(1,jo)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn6(in,jn)=tmpo5(io,jo)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn5(in,jn)=tmpn6(in,jn)
+               enddo
+            enddo
+        call gr_ecrit_fi(1,ngridn,imn,jmn+1,tmpn5,yv1n)
+
+        call initial0((imo+1)*(jmo+1),tmpo6)
+        call initial0(imo*(jmo+1),tmpo5)
+        call initial0(imn*(jmn+1),tmpn5)
+        call initial0((imn+1)*(jmn+1),tmpn6)
+        call gr_fi_ecrit(1,ngrido,imo,jmo+1,yu1o,tmpo5)
+
+           do jo=1,jmo+1
+              do io=1,imo
+                tmpo6(io,jo)=tmpo5(io,jo)
+              enddo
+           enddo
+
+                tmpo6(imo+1,1)=yu1o(1)
+                tmpo6(imo+1,jmo+1)=yu1o(ngrido)
+            do jo=2,jmo
+                tmpo6(imo+1,jo)=tmpo5(1,jo)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn6(in,jn)=tmpo5(io,jo)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               do in=1,imn
+                tmpn5(in,jn)=tmpn6(in,jn)
+               enddo
+            enddo
+        call gr_ecrit_fi(1,ngridn,imn,jmn+1,tmpn5,yu1n)
+c==================================================================
+	if (avant) then
+c Simu directe
+         do l=1,llm
+          do ig=1,ngridn
+	     zmfd(ig,l)=mfdn(ig,l)
+             zmfu(ig,l)=mfun(ig,l)
+             zen_d(ig,l)=en_dn(ig,l)
+             zde_d(ig,l)=de_dn(ig,l)
+             zen_u(ig,l)=en_un(ig,l)
+             zde_u(ig,l)=de_un(ig,l)
+          enddo
+       enddo
+      else
+c   Simu retro
+       do l=1,llm
+          do ig=1,ngridn
+             zmfd(ig,l)=-mfdn(ig,l)
+             zmfu(ig,l)=-mfun(ig,l)
+             zen_d(ig,l)=en_dn(ig,l)
+             zde_d(ig,l)=de_dn(ig,l)
+             zen_u(ig,l)=en_un(ig,l)
+             zde_u(ig,l)=de_un(ig,l)
+          enddo
+       enddo
+      endif
+
+c-----------------------------------------------------------------------
+c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
+c-----------------------------------------------------------------------
+
+         call gr_dyn_fi(llm,iip1,jjp1,ngridn,massemn,massefi)
+
+      print*,'Ap redec irec'
+         do ig=1,ngridn
+            zcontrole(ig)=1.
+         enddo
+c   zmass=(max(massemn(ig,l),massemn(ig,l-1))/airefin(ig)
+         do l=2,llm
+            do ig=1,ngridn
+               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefin(ig)
+               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
+               if(zflux.gt.0.9*zmass) then
+                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
+               endif
+            enddo
+         enddo
+
+         do ig=1,ngridn
+            if(zcontrole(ig).lt.0.99999) then
+               print*,'ATTENTION !!! on reduit les flux de masse '
+               print*,'convectifs au point ig=',ig
+            endif
+         enddo
+
+         call gr_fi_dyn(1,ngridn,iip1,jjp1,zcontrole,tmpdyn)
+
+         do l=1,llm
+            do ig=1,ngridn
+               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
+               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
+               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
+               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
+               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
+               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
+            enddo
+         enddo
+	endif ! physic
+
+      endif ! irec=0
+
+
+      RETURN
+      END
+
+
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/run.def
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/run.def	(revision 3)
+++ 	(revision )
@@ -1,187 +1,0 @@
-
------------------------------------------------------------------------ 
-Parametres de controle du run:                                          
-------------------------------                                          
-
-- Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici ) 
-   dayref
- 350
-
--  Annee de l'etat  initial (   avec  4  chiffres   )                        
-   anneeref
- 1987
-
-- Nombre de jours d'integration                                         
-     nday
- 2
-
-- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
- day_step
- 1440
-
-- periode pour le pas Matsuno (en pas)                                  
-  iperiod
- 5
-
-- periode de sortie des variables de controle (en pas)                  
-  iconser
- 5
-
-- periode d'ecriture du fichier histoire (en jour)                      
-    iecri
- 100
-
-- periode de stockage fichier histmoy (en jour)                         
- periodav
- 60.
-
-- periode de la dissipation (en pas)                                    
-  idissip
- 10
-
-- choix de l'operateur de dissipation (star ou  non star )              
- lstardis
- T
-
-- nombre d'iterations de l'operateur de dissipation   gradiv            
-nitergdiv
- 1
-
-- nombre d'iterations de l'operateur de dissipation  nxgradrot          
-nitergrot
- 2
-
-- nombre d'iterations de l'operateur de dissipation  divgrad            
-   niterh
- 2
-
-- temps de dissipation des plus petites long.d ondes pour u,v (gradiv)  
- tetagdiv
- 3000.
-
-- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
- tetagrot
- 3000.
-
-- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
- tetatemp
- 3000.
-
-- coefficient pour gamdissip                                            
-  coefdis
- 0.
-
-- choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) 
-  purmats
- F
-
-- avec ou sans physique                                                 
-   physic
- T
-
-- periode de la physique (en pas)                                       
-  iphysiq
- 15
-
-- frequence (en  jours ) de l'ecriture du fichier histphy               
- ecritphy
- 4
-
--  Cycle diurne  ou non                 
- cycle_diurne
- T
-
--  Soil Model  ou non               
- soil_model
- F
-
--  Choix ou non  de  New oliq               
- new_oliq
- T
-
--  Orodr  ou  non   pour l orographie              
-  ok_orodr
- T
-
--  Orolf  ou  non   pour l orographie              
-  ok_orolf
- T
-
--   Si = .T. ,  lecture du fichier limit avec la bonne annee             
-  ok_limitvrai
- T
-
-- Nombre  d'appels des routines de rayonnements ( par jour)                 
-  nbapp_rad
- 12
-
--  Flag  pour la convection ( 1 pour LMD,  2 pour Tiedtke, 3  CCM )             
-  iflag_con
- 2
-
-- longitude en degres du centre du zoom                                 
-   clon
- 63.
-
-- latitude en degres du centre du zoom                                  
-   clat
- 0.
-
-- facteur de grossissement du zoom,selon longitude                      
-  grossismx
- 2.5
-
-- facteur de grossissement du zoom ,selon latitude                      
- grossismy
- 2.5
-
--  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
-  fxyhypb
- T
-
-- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
-   dzoomx
- 0.291667
-
-- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
-   dzoomy
- 0.291667
-
--  Fonction  f(y) avec y = Sin(latit.) si = .true. , sinon y = latit.         
-  ysinus
- T
-
-c
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-cc
-c   Autres  parametres ou cles  , non places dans run.def  mais
-c             dans les routines .
-cc
-ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
-cc
-cc  A )   iadv(iq )  , iq =1, nqmx , avec  iadv = 1  , shema humid.
-cc                                                  specifique LMD
-cc
-cc                                avec  iadv = 2  , shema amont
-cc
-cc                (  avec a l'interieur de amont , la cle amont_qs ) 
-cc
-cc                                avec  iadv = 3 , shema Van_Leer
-cc
-cc                                           dans  ***  gcm.F  ****
-cc 
-cc  B )  ok_oasis   , pour coupleur Oasis  , dans  *** physiq.F ***
-cc
-cc  C )  ok_ocean                            dans  *** physiq.F ***
-cc
-cc  D )  ok_journe , ok_instan, ok_region   pour sorties analyses
-c
-cc                                           dans  *** physiq.F ***
-cc
-cc  E ) nvm  : nbre  de vegetations    
-cc                                           dans  *** physiq.F ***
-
-cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
-cc                                          dans  *** inigeom.F ***
-
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/serre.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/serre.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/serre.h	(revision 300)
@@ -1,6 +1,9 @@
+c
+c $Header$
+c
 c..include serre.h
 c
        REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
-     ,  grossismx, grossismy, dzoomx, dzoomy
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
        COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
-     ,  grossismx, grossismy, dzoomx, dzoomy
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/sortvarc0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc0.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/sortvarc0.F	(revision 300)
@@ -1,4 +1,5 @@
       SUBROUTINE sortvarc0
-     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time )
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
       IMPLICIT NONE
 
@@ -32,4 +33,5 @@
       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)
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/startvar.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/startvar.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/startvar.F	(revision 300)
@@ -1,2 +1,3 @@
+! $Header$
       MODULE startvar
     !
@@ -314,8 +315,14 @@
     !
       CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
-     . iml-1, jml, lon_in, lat_in, 
-     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, tmp_int)
-    !
-      masque(:,:) = FLOAT(tmp_int(:,:))
+     $    iml-1, jml, lon_in, lat_in, 
+    !     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, tmp_int)
+    ! PB masque avec % terre mai 2000
+     $    phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque)
+      phis = phis * 9.81
+!      write(*,*)'phis sortie grid_noro'
+!      write(*,*)phis
+    !
+    !PB supression ligne suivant pour masque avec % terre
+    !     masque(:,:) = FLOAT(tmp_int(:,:))
     !
     !  Compute surface roughness
@@ -391,4 +398,15 @@
               ENDIF
               CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ)
+    ! PB ajout pour masque terre mer fractionneiare    
+          CASE ('zmasq')
+              IF (.NOT. ALLOCATED(masque) ) THEN
+                  CALL start_init_orog ( iml, jml,lon_in, lat_in)
+              ENDIF
+              IF ( SIZE(masque) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+             ENDIF
+             CALL gr_dyn_fi(1, iml, jml, nbindex, masque, champ)
             CASE ('zmea')
               IF ( .NOT.ALLOCATED(relief)) THEN
@@ -660,5 +678,5 @@
               DO il=1,lml
                 xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
-                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
                 champ(:,1,il) = xppn
                 champ(:,jml,il) = xpps
@@ -689,5 +707,5 @@
               DO il=1,lml
                 xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
-                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
                 champ(:,1,il) = xppn
                 champ(:,jml,il) = xpps
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/temps.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/temps.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/temps.h	(revision 300)
@@ -1,7 +1,8 @@
-c-----------------------------------------------------------------------
-c INCLUDE 'temps.h'
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
 
-      COMMON/temps/itaufin,dt,
-     s  day_ini,day_end,anne_ini
+      COMMON/temps/itaufin,dt, day_ini,day_end,anne_ini
 
       INTEGER  itaufin
@@ -9,3 +10,3 @@
       REAL     dt
 
-c-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/temps.inc
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/temps.inc	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/temps.inc	(revision 300)
@@ -0,0 +1,11 @@
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin,dt, &
+     &  day_ini,day_end,anne_ini
+
+      INTEGER  itaufin
+      INTEGER*4 day_ini,day_end,anne_ini
+      REAL     dt
+
+!-----------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/tracvl.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/tracvl.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/tracvl.F	(revision 300)
@@ -1,4 +1,4 @@
       SUBROUTINE tracvl(numvanle,iapp_tracvl,nq,pbaru,pbarv ,
-     *                            p,  masse , q, iapptrac    )
+     *                    p, masse , q, iapptrac, iadv1, teta, pk  )
 c
 c     Auteur :  F. Hourdin
@@ -6,4 +6,6 @@
 c
 ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c                 F. Codron     (10/99)
+
 c
       IMPLICIT NONE
@@ -15,10 +17,15 @@
 #include "comgeom.h"
 
-      INTEGER nq,iapp_tracvl
+c     .... Arguments  ....
+c
+      INTEGER numvanle, nq, iapp_tracvl, iapptrac, iadv1
 
       REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
       REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
-      REAL p( ip1jmp1,llmp1 )
+      REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm)
+      REAL pk(ip1jmp1,llm)
 
+c     ....  var. locales  .....
+c
       REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
       REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
@@ -26,13 +33,13 @@
       REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
 
-      INTEGER iapptrac
 
-      INTEGER iadvtr, numvanle
+      INTEGER iadvtr, numvan
       INTEGER ij,l,iq
       REAL zdpmin, zdpmax
       EXTERNAL  minmax
- 
-      SAVE iadvtr, massem,pbaruc,pbarvc
+      SAVE iadvtr, massem, pbaruc, pbarvc, numvan
       DATA iadvtr/0/
+
+      numvan = numvanle
 
       IF(iadvtr.EQ.0) THEN
@@ -99,5 +106,14 @@
 
 c   Advection proprement dite.
-         DO iq = numvanle, nq
+c
+c   test sur iadv1 pour le schema de vapeur d'eau
+c
+         IF (numvanle.EQ.1.AND.iadv1.EQ.4) THEN
+           CALL vlspltqs( q(1,1,1), 2., massem, wg ,
+     *                 pbarug,pbarvg,dtvr,p,pk,teta )
+           numvan = 2
+         ENDIF
+
+         DO iq = numvan, nq
           CALL vlsplt( q(1,1,iq), 2. ,massem,wg,pbarug,pbarvg,dtvr )
          ENDDO
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/vanleer.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/vanleer.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/vanleer.F	(revision 300)
@@ -1,8 +1,10 @@
       SUBROUTINE vanleer(numvanle,iapp_tracvl,nq,q,pbaru,pbarv ,
-     *                                    p ,masse,  dq          )
+     *                     p ,masse, dq ,  iadv1, teta, pk      )
 c
       IMPLICIT NONE
 c
-c     Auteurs:   F.Hourdin , P.Le Van, F.Forget 
+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
@@ -18,8 +20,8 @@
 c   Arguments:
 c   ----------
-      INTEGER nq,numvanle,iapp_tracvl 
+      INTEGER nq, numvanle, iapp_tracvl, iadv1 
       REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
       REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nq),dq( ip1jmp1,llm,nq )
-
+      REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
 c  ..................................................................
 c
@@ -28,4 +30,6 @@
 c     numvanle est le numero du premier traceur qui appelle le
 c       shema de Van-Leer  (  1<=  numvanle <=  nqmx )  .
+c     si numvanle=1, iadv1=3 si Van-Leer seul, iadv1=4 si 
+c     Van-Leer+humidite specifique.
 c  ..................................................................
 c
@@ -61,5 +65,5 @@
 
       CALL tracvl( numvanle,iapp_tracvl,nq,pbaru,pbarv,p , masse,q  ,
-     *                                iapptrac                       )
+     *                      iapptrac, iadv1, teta ,pk              )
 
       IF( numvanle.EQ.1 ) THEN
Index: LMDZ.3.3/tags/CCM1_0/libf/dyn3d/vlspltqs.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/dyn3d/vlspltqs.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/dyn3d/vlspltqs.F	(revision 300)
@@ -0,0 +1,774 @@
+       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   --------------------------------------------------------------------
+      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)
+
+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.
+        DO l = 1, llm
+         DO ij = 1, ip1jmp1
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = 1, ip1jmp1
+          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      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
+      EXTERNAL  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.1) 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
+      EXTERNAL  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     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      DO l=1,llm
+       DO ij=1,ip1jm
+         IF( masse_adv_v(ij,l).GT.0. ) THEN
+           qbyv(ij,l)= 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: LMDZ.3.3/tags/CCM1_0/libf/filtrez/filtreg.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/filtreg.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/filtrez/filtreg.F	(revision 300)
@@ -290,8 +290,8 @@
  100  CONTINUE
 c
-1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fil
-     *-trer, sur la grille des scalaires'/)
-2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fil
-     *-trer, sur la grille de V ou de Z'/)
+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: LMDZ.3.3/tags/CCM1_0/libf/filtrez/jacobi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/jacobi.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/filtrez/jacobi.F	(revision 300)
@@ -1,4 +1,4 @@
       SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
-      PARAMETER (NMAX=200)
+      PARAMETER (NMAX=400)
       DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
       IF (n.gt.nmax) THEN
Index: LMDZ.3.3/tags/CCM1_0/libf/filtrez/parafilt.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/parafilt.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/filtrez/parafilt.h	(revision 300)
@@ -4,5 +4,5 @@
 c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
 c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
-         PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+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)
@@ -16,6 +16,12 @@
 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:
-ccc      PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+      PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
 c
 c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/FCTTRE.inc
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/FCTTRE.inc	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/FCTTRE.inc	(revision 300)
@@ -0,0 +1,36 @@
+!      ------------------------------------------------------------------
+!      This COMDECK includes the Thermodynamical functions for the cy39
+!       ECMWF Physics package.
+!       Consistent with YOMCST Basic physics constants, assuming the
+!       partial pressure of water vapour is given by a first order
+!       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+!       in YOETHF
+!     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+!
+      FOEEW ( PTARG,PDELARG ) = EXP ( &
+     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+!
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+!
+      qsats(ptarg) = 100.0 * 0.622 * 10.0 &
+     &           ** (2.07023 - 0.00320991 * ptarg &
+     &           - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
+      qsatl(ptarg) = 100.0 * 0.622 * 10.0 &
+     &           ** (23.8319 - 2948.964 / ptarg &
+     &           - 5.028 * LOG10(ptarg) &
+     &           - 29810.16 * EXP( - 0.0699382 * ptarg) &
+     &           + 25.21935 * EXP( - 2999.924 / ptarg))
+!
+      dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg &
+     &                     +2484.896*LOG(10.)/ptarg**2 &
+     &                     -0.00320991*LOG(10.))
+      dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)* &
+     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg &
+     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg) &
+     &                +29810.16*0.0699382*EXP(-0.0699382*ptarg))
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOEGWD.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOEGWD.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOEGWD.h	(revision 300)
@@ -3,4 +3,7 @@
 C     -----------------------------------------------------------------
 C
+      integer NKTOPG,NSTRA
+      real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+      real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
       COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
      *        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOETHF.inc
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOETHF.inc	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOETHF.inc	(revision 300)
@@ -0,0 +1,12 @@
+!*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+!
+!     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+!                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+!                ICE(*R_IES*).
+!     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+!     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+!
+      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
+      REAL RVTMP2, RHOH2O
+      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES, &
+     &               RVTMP2, RHOH2O
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOMCST.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOMCST.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOMCST.h	(revision 300)
@@ -1,23 +1,23 @@
-C A1.0 Fundamental constants
+! A1.0 Fundamental constants
       REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
-C A1.1 Astronomical constants
+! A1.1 Astronomical constants
       REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
-c A1.1.bis Constantes concernant l'orbite de la Terre:
+! A1.1.bis Constantes concernant l'orbite de la Terre:
       REAL R_ecc, R_peri, R_incl
-C A1.2 Geoide
+! A1.2 Geoide
       REAL RA,RG,R1SA
-C A1.3 Radiation
+! A1.3 Radiation
       REAL RSIGMA,RI0
-C A1.4 Thermodynamic gas phase
+! A1.4 Thermodynamic gas phase
       REAL R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
       REAL RKAPPA,RETV
-C A1.5,6 Thermodynamic liquid,solid phases
+! A1.5,6 Thermodynamic liquid,solid phases
       REAL RCW,RCS
-C A1.7 Thermodynamic transition of phase
+! A1.7 Thermodynamic transition of phase
       REAL RLVTT,RLSTT,RLMLT,RTT,RATM
-C A1.8 Curve of saturation
+! A1.8 Curve of saturation
       REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
       REAL RALPD,RBETD,RGAMD
-C
+!
       COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO
      S      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA
@@ -31,3 +31,3 @@
      S      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS
      S      ,RALPD ,RBETD ,RGAMD
-C    ------------------------------------------------------------------
+!    ------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOMCST.inc
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOMCST.inc	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/YOMCST.inc	(revision 300)
@@ -0,0 +1,26 @@
+! A1.0 Fundamental constants
+      REAL :: RPI,RCLUM,RHPLA,RKBOL,RNAVO
+! A1.1 Astronomical constants
+      REAL :: RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+! A1.1.bis Constantes concernant l'orbite de la Terre:
+      REAL :: R_ecc, R_peri, R_incl
+! A1.2 Geoide
+      REAL :: RA,RG,R1SA
+! A1.3 Radiation
+      REAL :: RSIGMA,RI0
+! A1.4 Thermodynamic gas phase
+      REAL :: R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL :: RKAPPA,RETV
+! A1.5,6 Thermodynamic liquid,solid phases
+      REAL :: RCW,RCS
+! A1.7 Thermodynamic transition of phase
+      REAL :: RLVTT,RLSTT,RLMLT,RTT,RATM
+! A1.8 Curve of saturation
+      REAL :: RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL :: RALPD,RBETD,RGAMD
+!
+      COMMON/YOMCST/RPI ,RCLUM, RHPLA, RKBOL, RNAVO ,RDAY  ,REA &
+     & ,REPSM ,RSIYEA,RSIDAY,ROMEGA ,R_ecc, R_peri, R_incl, RA    ,RG &
+     & ,R1SA ,RSIGMA,RI0,R ,RMD   ,RMV   ,RD    ,RV    ,RCPD ,RCPV,RCVD &
+     & ,RCVV  ,RKAPPA,RETV ,RCW   ,RCS ,RLVTT ,RLSTT ,RLMLT ,RTT ,RATM &
+     & ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS ,RALPD ,RBETD ,RGAMD
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/ajsec.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/ajsec.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/ajsec.F	(revision 300)
@@ -1,3 +1,3 @@
-      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q, itr, tr, d_tr)
+      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
       IMPLICIT none
 c======================================================================
@@ -16,8 +16,4 @@
       REAL t(klon,klev), q(klon,klev)
       REAL d_t(klon,klev), d_q(klon,klev)
-c
-      INTEGER it, itr
-      REAL tr(klon,klev,nbtr), d_tr(klon,klev,nbtr)
-      REAL ztr(klon,klev,nbtr), trm(nbtr)
 c
       INTEGER limbas, limhau ! les couches a ajuster
@@ -45,13 +41,4 @@
       ENDDO
       ENDDO
-      IF (itr.GE.1) THEN
-      DO it = 1, itr
-      DO k = 1, klev
-      DO i = 1, klon
-         d_tr(i,k,it) = 0.0
-      ENDDO
-      ENDDO
-      ENDDO
-      ENDIF
 c------------------------------------- detection des profils a modifier
       DO k = limbas, limhau
@@ -62,14 +49,4 @@
       ENDDO
       ENDDO
-c
-      IF (itr.GE.1) THEN
-      DO it = 1, itr
-      DO k = limbas, limhau
-      DO i = 1, klon
-         ztr(i,k,it) = tr(i,k,it)
-      ENDDO
-      ENDDO
-      ENDDO
-      ENDIF
 c
       DO k = limbas, limhau
@@ -102,19 +79,8 @@
               hm = zh(i,k2)
               qm = zq(i,k2)
-              IF (itr.GE.1) THEN
-              DO it = 1, itr
-                trm(it) = ztr(i,k2,it)
-              ENDDO
-              ENDIF
  8020         CONTINUE
                 sm = sm +zpkdp(i,k)
                 hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
                 qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
-                IF (itr.GE.1) THEN
-                DO it = 1, itr
-                trm(it) = trm(it) +
-     .                    zpkdp(i,k) * (ztr(i,k,it)-trm(it)) / sm
-                ENDDO
-                ENDIF
                 down = .FALSE.
                 IF (k1 .ne. limbas) THEN
@@ -137,11 +103,4 @@
                 zq(i,k) = qm
               ENDDO
-              IF (itr.GE.1) THEN
-              DO it = 1, itr
-              DO k = k1, k2
-                ztr(i,k,it) = trm(it)
-              ENDDO
-              ENDDO
-              ENDIF
               k2 = k2 + 1
             ENDIF
@@ -173,32 +132,4 @@
          d_q(i,k) = 0.0
       ENDDO
-      ENDDO
-      ENDIF
-c
-      IF (itr.GE.1) THEN
-      DO it = 1, itr
-c
-      DO k = limbas, limhau
-      DO i = 1, klon
-         d_tr(i,k,it) = ztr(i,k,it) - tr(i,k,it)
-      ENDDO
-      ENDDO
-c
-      IF (limbas.GT.1) THEN
-      DO k = 1, limbas-1
-      DO i = 1, klon
-         d_tr(i,k,it) = 0.0
-      ENDDO
-      ENDDO
-      ENDIF
-c
-      IF (limhau.LT.klev) THEN
-      DO k = limhau+1, klev
-      DO i = 1, klon
-         d_tr(i,k,it) = 0.0
-      ENDDO
-      ENDDO
-      ENDIF
-c
       ENDDO
       ENDIF
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/albedo.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/albedo.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/albedo.F	(revision 300)
@@ -17,5 +17,6 @@
 c
       REAL fmagic ! un facteur magique pour regler l'albedo
-      PARAMETER (fmagic=0.7)
+ccc      PARAMETER (fmagic=0.7)
+      PARAMETER (fmagic=1.1)
       INTEGER npts ! il controle la precision de l'integration
       PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
@@ -83,4 +84,8 @@
       REAL rmu0(klon), albedo(klon)
 c
+      REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+      PARAMETER (fmagic=1.1)
+c
       REAL fauxo
       INTEGER i
@@ -88,5 +93,5 @@
       DO i = 1, klon
          fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
-         albedo(i) = 1.1*( .03 + .630/( 1. + fauxo*fauxo))
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))
          albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
       ENDDO
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/atm2geo.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/atm2geo.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/atm2geo.F	(revision 300)
@@ -0,0 +1,44 @@
+C
+      SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+cc
+cc Change wind local atmospheric coordinates to
+cc geocentric
+cc
+c$$$      INCLUDE 'param.h'
+c
+      INTEGER, INTENT (in)              :: im, jm
+      REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
+      REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+      REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
+c
+      REAL, PARAMETER :: rpi = 3.141592653E0
+      REAL, PARAMETER :: rad = rpi / 180.0E0
+c
+      REAL, DIMENSION (im,jm) :: zsinlon, zcoslon
+      REAL, DIMENSION (im,jm) :: zsinlat, zcoslat
+c
+      LOGICAL, SAVE :: linit = .FALSE.
+c
+c$$$      IF ( .NOT. linit ) THEN 
+          zsinlon = SIN (rad * plon)
+          zcoslon = COS (rad * plon)
+          zsinlat = SIN (rad * plat)
+          zcoslat = COS (rad * plat)
+          linit = .TRUE.
+c$$$      ENDIF 
+c
+      pxx = - zsinlon * pte - zsinlat * zcoslon * ptn
+      pyy =   zcoslon * pte - zsinlat * zsinlon * ptn
+      pzz =   zcoslat * ptn
+c
+c Value at North Pole
+      pxx ( :,  1) = - ptn ( 1, 1)
+      pyy ( :,  1) = - pte ( 1, 1)
+      pzz ( :,  1) = 0.0
+c Value at South Pole
+      pxx ( :, jm) = + ptn ( 1, jm)
+      pyy ( :, jm) = + pte ( 1, jm)
+      pzz ( :, jm) = 0.0
+c
+      RETURN 
+      END SUBROUTINE atm2geo
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/calcratqs.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/calcratqs.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/calcratqs.F	(revision 300)
@@ -0,0 +1,162 @@
+c $Header$
+      SUBROUTINE calcratqs (
+     I            paprs,pplay,q_seri,d_t_con,d_t_ajs
+     O           ,ratqs,zpt_conv)
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c
+c Objet: Moniteur general de la physique du modele
+cAA      Modifications quant aux traceurs :
+cAA                  -  uniformisation des parametrisations ds phytrac
+cAA                  -  stockage des moyennes des champs necessaires
+cAA                     en mode traceur off-line 
+c======================================================================
+c    modif   ( P. Le Van ,  12/10/98 )
+c
+c  Arguments:
+c
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+#include "dimensions.h"
+#include "dimphy.h"
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL d_t_con(klon,klev)
+      REAL d_t_ajs(klon,klev)
+      REAL ratqs(klon,klev)
+      LOGICAL pt_conv(klon,klev)
+      REAL q_seri(klon,klev)
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+
+
+      REAL ratqsmin,ratqsmax,zx,epmax
+      REAL ratqs1,ratqs2,ratqs3,ratqs4
+      REAL ratqsc1,ratqsc2,ratqsc3,ratqsc4
+      INTEGER i,k
+      INTEGER flag_ratqs
+      save ratqsmin,ratqsmax,flag_ratqs,epmax
+      save ratqs1,ratqs2,ratqs3,ratqs4
+      save ratqsc1,ratqsc2,ratqsc3,ratqsc4
+      real zpt_conv(klon,klev)
+
+      REAL zx_min
+      PARAMETER (zx_min=1.0)
+      REAL zx_max
+      PARAMETER (zx_max=0.1)
+
+      flag_ratqs=1
+      flag_ratqs=0
+	zpt_conv=0.
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c
+      if (flag_ratqs.eq.0) then
+
+         ratqsmax=0.01
+         ratqsmin=0.3
+
+         if (firstcall) print*,'RATQS ANCIEN '
+         do k=1,klev
+         do i=1,klon
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs(i,k)= zx * (ratqsmax-ratqsmin) + ratqsmin
+         enddo
+         enddo
+
+      else
+
+c  On aplique un ratqs "interactif" a toutes les mailles affectees
+c  par la convection ou se trouvant "sous" une maille affectee.
+         do i=1,klon
+            pt_conv(i,klev)=.false.
+         enddo
+         do k=klev-1,1,-1
+            do i=1,klon
+               pt_conv(i,k)=pt_conv(i,k+1).or.
+     s               (abs(d_t_con(i,k))+abs(d_t_ajs(i,k))).gt.1.e-8
+               if(pt_conv(i,k)) then
+                  zpt_conv(i,k)=1.
+               else
+                  zpt_conv(i,k)=0.
+               endif
+            enddo
+         enddo
+
+         if (flag_ratqs.eq.1) then
+
+            ratqsmin=0.4
+            ratqsmax=0.99
+            if (firstcall) print*,'RATQS INTERACTIF '
+            do k=1,klev
+                do i=1,klon
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=0.01
+     s                +0.25*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                      ratqs(i,k)=max(ratqs(i,k),0.1)
+                   else
+                      ratqs(i,k)=0.01+(ratqsmin-0.01)*
+     s             min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.)
+                   endif
+                enddo
+            enddo
+         else if (flag_ratqs.eq.2) then
+            do k=1,klev
+                do i=1,klon
+                   ratqs(i,k)=0.001+
+     s             (q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+                   if (pt_conv(i,k)) then
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmax)
+                   else
+                      ratqs(i,k)=min(ratqs(i,k),ratqsmin)
+                   endif
+                enddo
+            enddo
+         else
+            do k=1,klev
+               do i=1,klon
+                  if (pplay(i,k).ge.95000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc1
+                     else
+                        ratqs(i,k)=ratqs1
+                     endif
+                  else if (pplay(i,k).ge.75000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc2
+                     else
+                        ratqs(i,k)=ratqs2
+                     endif
+                  else if (pplay(i,k).ge.50000.) then
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc3
+                     else
+                        ratqs(i,k)=ratqs3
+                     endif
+                  else
+                     if (pt_conv(i,k)) then
+                        ratqs(i,k)=ratqsc4
+                     else
+                        ratqs(i,k)=ratqs4
+                     endif
+                  endif
+               enddo
+            enddo
+         endif
+
+      endif
+
+      firstcall=.false.
+
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/clift.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/clift.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/clift.F	(revision 300)
@@ -0,0 +1,70 @@
+c $Header$
+        SUBROUTINE CLIFT (P,T,RR,RS,PLCL,DPLCLDT,DPLCLDQ)
+C***************************************************************
+C*                                                             *
+C* CLIFT : COMPUTE LIFTING CONDENSATION LEVEL AND ITS          *
+C*         DERIVATIVES RELATIVE TO T AND R                     *
+C*   (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)   *
+C*                                                             *
+C* written by   : GRANDPEIX Jean-Yves, 17/11/98, 12.39.01      *
+C* modified by :                                               *
+C***************************************************************
+C*
+C*Arguments :
+C*
+C* Input :  P = pressure of level from wich lifting is performed
+C*          T = temperature of level P
+C*          RR = vapour mixing ratio at level P
+C*          RS = vapour saturation mixing ratio at level P
+C*
+C* Output : PLCL = lifting condensation level
+C*          DPLCLDT = derivative of PLCL relative to T
+C*          DPLCLDQ = derivative of PLCL relative to R
+C*
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c      CPD = 3.5 * RD
+c      CPV = 4.0 * RV
+c      CL = 4218.0
+c      CI=2090.0
+c      CPVMCL=CL-CPV
+c      CLMCI=CL-CI
+c      EPS=RD/RV
+c      ALV0=2.5008E+06
+c      ALF0=3.34E+05
+c
+c on utilise les constantes thermo du Centre Europeen: (sb)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+c
+c      Bolton formula coefficients :
+      A = 1669.0
+      B = 122.0
+c
+      RH=RR/RS
+      CHI=T/(A-B*RH-T)
+      PLCL=P*(RH**CHI)
+c
+      ALV = ALV0 - CPVMCL*(T-273.15)
+c
+c -- sb: correction:
+c       DPLCLDQ = PLCL*CHI*( 1./RR - B*CHI/T/RS*ALOG(RH) )
+      DPLCLDQ = PLCL*CHI*( 1./RR + B*CHI/T/RS*ALOG(RH) )
+c sb --
+c
+      DPLCLDT = PLCL*CHI*((A-B*RH*(1.+ALV/RV/T))/T**2*CHI*ALOG(RH)
+     $                    - ALV/RV/T**2 )
+c
+c
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/clim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/clim.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/clim.h	(revision 300)
@@ -42,5 +42,5 @@
       PARAMETER ( CLIM_Void    = 0  )
       PARAMETER ( CLIM_MaxMod  = 8 )
-      PARAMETER ( CLIM_MaxPort = 16 )
+      PARAMETER ( CLIM_MaxPort = 40 )
       PARAMETER ( CLIM_MaxSegments = 160 )
       PARAMETER ( CLIM_MaxLink = CLIM_MaxMod * CLIM_MaxPort )
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/clmain.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/clmain.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/clmain.F	(revision 300)
@@ -1,9 +1,19 @@
-      SUBROUTINE clmain(dtime,pctsrf,t,q,u,v,
-     .                  soil_model,ts,soilcap,soilflux,
-     .                  paprs,pplay,radsol,snow,qsol,
-     .                  xlat, rugos,
+c
+c $Header$
+c
+
+      SUBROUTINE clmain(dtime,itap,date0,pctsrf,
+     .                  t,q,u,v,
+     .                  jour, rmu0,
+     .                  ok_veget, ocean, npas, nexca, ts,
+     .                  soil_model,ftsoil,
+     .                  paprs,pplay,radsol,snow,qsol,evap,albe,alblw,
+     .                  fluxlat,
+     .                  rain_f, snow_f, solsw, sollw, sollwdown, fder,
+     .                  rlon, rlat, cufi, cvfi, rugos,
+     .                  debut, lafin, agesno,rugoro,
      .                  d_t,d_q,d_u,d_v,d_ts,
      .                  flux_t,flux_q,flux_u,flux_v,cdragh,cdragm,
-     .                  rugmer, dflux_t,dflux_q,
+     .                  dflux_t,dflux_q,
      .                  zcoefh,zu1,zv1)
 cAA .                  itr, tr, flux_surf, d_tr)
@@ -23,5 +33,6 @@
 cAA il faudra sortir ces memes champs en leur ajoutant une dimension, 
 cAA c'est a dire nbsrf (nbre de subsurface).
- 
+      USE ioipsl
+      USE interface_surf
       IMPLICIT none
 c======================================================================
@@ -30,4 +41,6 @@
 c Arguments:
 c dtime----input-R- interval du temps (secondes)
+c itap-----input-I- numero du pas de temps
+c date0----input-R- jour initial
 c t--------input-R- temperature (K)
 c q--------input-R- vapeur d'eau (kg/kg)
@@ -38,9 +51,8 @@
 c pplay----input-R- pression au milieu de couche (Pa)
 c radsol---input-R- flux radiatif net (positif vers le sol) en W/m**2
-c capsol---input-R- inversion de l'effective capacite du sol (J/m2/K)
-c beta-----input-R- coefficient de l'evaporation reelle (0 a 1)
-c dif_grnd-input-R- coeff. de diffusion (chaleur) vers le sol profond
-c xlat-----input-R- latitude en degree
+c rlat-----input-R- latitude en degree
 c rugos----input-R- longeur de rugosite (en m)
+c cufi-----input-R- resolution des mailles en x (m)
+c cvfi-----input-R- resolution des mailles en y (m)
 c
 c d_t------output-R- le changement pour "t"
@@ -54,5 +66,4 @@
 c flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
 c flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
-c rugmer---output-R- longeur de rugosite sur mer (m)
 c dflux_t derive du flux sensible
 c dflux_q derive du flux latent
@@ -68,19 +79,26 @@
 #include "dimphy.h"
 #include "indicesol.h"
-c
-      LOGICAL soil_model
+c$$$ PB ajout pour soil
+#include "dimsoil.h"
 c
       REAL dtime
+      real date0
+      integer itap
       REAL t(klon,klev), q(klon,klev)
       REAL u(klon,klev), v(klon,klev)
       REAL paprs(klon,klev+1), pplay(klon,klev), radsol(klon)
-      REAL xlat(klon)
+      REAL rlon(klon), rlat(klon), cufi(klon), cvfi(klon)
       REAL d_t(klon, klev), d_q(klon, klev)
       REAL d_u(klon, klev), d_v(klon, klev)
-      REAL flux_t(klon,klev), flux_q(klon,klev)
+      REAL flux_t(klon,klev, nbsrf), flux_q(klon,klev, nbsrf)
       REAL dflux_t(klon), dflux_q(klon)
-      REAL flux_u(klon,klev), flux_v(klon,klev)
-      REAL rugmer(klon)
+      REAL flux_u(klon,klev, nbsrf), flux_v(klon,klev, nbsrf)
+      REAL rugmer(klon), agesno(klon,nbsrf),rugoro(klon)
       REAL cdragh(klon), cdragm(klon)
+      integer jour            ! jour de l'annee en cours
+      real rmu0(klon)         ! cosinus de l'angle solaire zenithal
+      LOGICAL debut, lafin, ok_veget
+      character*6 ocean
+      integer npas, nexca
 cAA      INTEGER itr
 cAA      REAL tr(klon,klev,nbtr)
@@ -93,5 +111,16 @@
       REAL snow(klon,nbsrf)
       REAL qsol(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      REAL albe(klon,nbsrf)
+      REAL alblw(klon,nbsrf)
+c$$$ PB
+      REAL fluxlat(klon,nbsrf)
+C
+      real rain_f(klon), snow_f(klon)
+      REAL fder(klon)
+      REAL sollw(klon), solsw(klon), sollwdown(klon)
       REAL rugos(klon,nbsrf)
+C la nouvelle repartition des surfaces sortie de l'interface
+      REAL pctsrf_new(klon,nbsrf)
 cAA
       REAL zcoefh(klon,klev)
@@ -99,11 +128,23 @@
       REAL zv1(klon)
 cAA
+c$$$ PB ajout pour soil
+      LOGICAL soil_model
+      REAL ftsoil(klon,nsoilmx,nbsrf)
+      REAL ytsoil(klon,nsoilmx)
 c======================================================================
       EXTERNAL clqh, clvent, coefkz, calbeta, cltrac
 c======================================================================
-      REAL yts(klon), yrugos(klon), ypct(klon)
-      REAL ycal(klon), ybeta(klon), ydif(klon)
+      REAL yts(klon), yrugos(klon), ypct(klon), yz0_new(klon)
+      REAL yalb(klon)
+      REAL yalblw(klon)
       REAL yu1(klon), yv1(klon)
-      REAL yrugm(klon), yrads(klon)
+      real ysnow(klon), yqsol(klon), yagesno(klon)
+      real yrain_f(klon), ysnow_f(klon)
+      real ysollw(klon), ysolsw(klon), ysollwdown(klon)
+      real yfder(klon), ytaux(klon), ytauy(klon)
+      REAL yrugm(klon), yrads(klon),yrugoro(klon)
+c$$$ PB
+      REAL yfluxlat(klon)
+C
       REAL y_d_ts(klon)
       REAL y_d_t(klon, klev), y_d_q(klon, klev)
@@ -113,6 +154,4 @@
       REAL y_dflux_t(klon), y_dflux_q(klon)
       REAL ycoefh(klon,klev), ycoefm(klon,klev)
-      REAL ygamt(klon,2:klev) ! contre-gradient pour temperature
-      REAL ygamq(klon,2:klev) ! contre-gradient pour humidite
       REAL yu(klon,klev), yv(klon,klev)
       REAL yt(klon,klev), yq(klon,klev)
@@ -122,7 +161,9 @@
 cAA      REAL yflxsrf(klon,nbtr)
 c
+      LOGICAL contreg
+      PARAMETER (contreg=.TRUE.)
+c
       LOGICAL ok_nonloc
       PARAMETER (ok_nonloc=.FALSE.)
-      REAL y_cd_h(klon), y_cd_m(klon)
       REAL ycoefm0(klon,klev), ycoefh0(klon,klev)
 c
@@ -130,14 +171,65 @@
       REAL u1lay(klon), v1lay(klon)
       REAL delp(klon,klev)
-      REAL capsol(klon), beta(klon), dif_grnd(klon)
-      REAL cal(klon)
-      REAL soilcap(klon,nbsrf), soilflux(klon,nbsrf)
       REAL totalflu(klon)
       INTEGER i, k, nsrf 
 cAA   INTEGER it
       INTEGER ni(klon), knon, j
+c Introduction d'une variable "pourcentage potentiel" pour tenir compte
+c des eventuelles apparitions et/ou disparitions de la glace de mer
+      REAL pctsrf_pot(klon,nbsrf)
+      
 c======================================================================
       REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.
 c======================================================================
+c
+c maf pour sorties IOISPL en cas de debugagage
+c
+      CHARACTER*80 cldebug
+      SAVE cldebug
+      CHARACTER*8 cl_surf(nbsrf)
+      SAVE cl_surf
+      INTEGER nhoridbg, nidbg
+      SAVE nhoridbg, nidbg
+      INTEGER ndexbg(iim*(jjm+1))
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian
+      REAL tabindx(klon)
+      REAL debugtab(iim,jjm+1)
+      LOGICAL first_appel
+      SAVE first_appel
+      DATA first_appel/.false./
+      LOGICAL debugindex
+      SAVE debugindex
+      DATA debugindex/.false./
+#include "temps.h"
+      
+      IF (first_appel) THEN
+          first_appel=.false.
+!
+! initialisation sorties netcdf
+!
+          CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+          zjulian = zjulian + day_ini
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+          DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjm+1) = rlon(i+1)
+          ENDDO
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+          cldebug='sous_index'
+          CALL histbeg(cldebug, iim,zx_lon,jjm+1,zx_lat,1,iim,1,jjm
+     $        +1, 0,zjulian,dtime,nhoridbg,nidbg) 
+! no vertical axis
+          cl_surf(1)='ter'
+          cl_surf(2)='lic'
+          cl_surf(3)='oce'
+          cl_surf(4)='sic'
+          DO nsrf=1,nbsrf
+            CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim,
+     $          jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
+          END DO
+          CALL histend(nidbg)
+          CALL histsync(nidbg)
+      ENDIF 
+          
       DO k = 1, klev   ! epaisseur de couche
       DO i = 1, klon
@@ -164,19 +256,60 @@
          zv1(i) = 0.0
       ENDDO
+      ypct = 0.0
+      yts = 0.0
+      ysnow = 0.0
+      yqsol = 0.0
+      yalb = 0.0
+      yalblw = 0.0
+      yrain_f = 0.0
+      ysnow_f = 0.0
+      yfder = 0.0
+      ytaux = 0.0
+      ytauy = 0.0
+      ysolsw = 0.0
+      ysollw = 0.0
+      ysollwdown = 0.0
+      yrugos = 0.0
+      yu1 = 0.0
+      yv1 = 0.0
+      yrads = 0.0
+      ypaprs = 0.0
+      ypaprs = 0.0
+      ypplay = 0.0
+      ydelp = 0.0
+      yu = 0.0
+      yv = 0.0
+      yt = 0.0
+      yq = 0.0
+      pctsrf_new = 0.0
+      y_flux_u = 0.0
+      y_flux_v = 0.0
+C$$ PB
+      y_dflux_t = 0.0
+      y_dflux_q = 0.0
+      ytsoil = 999999.
+      yrugoro = 0.
+
       DO nsrf = 1, nbsrf
       DO i = 1, klon
          d_ts(i,nsrf) = 0.0
       ENDDO
-      ENDDO
+      END DO
+C§§§ PB
+      yfluxlat=0.
+      flux_t = 0.
+      flux_q = 0.
+      flux_u = 0.
+      flux_v = 0.
       DO k = 1, klev
       DO i = 1, klon
          d_t(i,k) = 0.0
          d_q(i,k) = 0.0
-         flux_t(i,k) = 0.0
-         flux_q(i,k) = 0.0
+c$$$         flux_t(i,k) = 0.0
+c$$$         flux_q(i,k) = 0.0
          d_u(i,k) = 0.0
          d_v(i,k) = 0.0
-         flux_u(i,k) = 0.0
-         flux_v(i,k) = 0.0
+c$$$         flux_u(i,k) = 0.0
+c$$$         flux_v(i,k) = 0.0
          zcoefh(i,k) = 0.0
       ENDDO
@@ -191,27 +324,19 @@
 cAA      ENDDO
 cAA      ENDIF
+
 c
 c Boucler sur toutes les sous-fractions du sol:
 c
+C Initialisation des "pourcentages potentiels". On considere ici qu'on 
+C peut avoir potentiellementdela glace sur tout le domaine oceanique 
+C (a affiner)
+
+      pctsrf_pot = pctsrf
+      pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+      pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+
       DO 99999 nsrf = 1, nbsrf
-c
-c prescrire les proprietes du sol:
-      CALL calbeta(dtime,nsrf,snow,qsol, beta,capsol,dif_grnd)
-      IF (.NOT.soil_model) THEN
-         DO i = 1, klon
-            cal(i) = RCPD * capsol(i)
-            totalflu(i) = radsol(i)
-         ENDDO
-      ELSE
-         DO i = 1, klon
-            totalflu(i) = soilflux(i,nsrf) + radsol(i)
-            IF (nsrf.EQ.is_oce) THEN
-               cal(i) = 0.0
-            ELSE
-               cal(i) = RCPD / soilcap(i,nsrf)
-            ENDIF
-         ENDDO
-      ENDIF
-c
+       totalflu = radsol
+
 c chercher les indices:
       DO j = 1, klon
@@ -220,5 +345,8 @@
       knon = 0
       DO i = 1, klon
-      IF (pctsrf(i,nsrf).GT.epsfra) THEN
+
+C pour determiner le domaine a traiter on utilise les surfaces "potentielles"
+C  
+      IF (pctsrf_pot(i,nsrf).GT.epsfra) THEN
          knon = knon + 1
          ni(knon) = i
@@ -226,4 +354,20 @@
       ENDDO
 c
+c      write(*,*)'CLMAIN, nsrf, knon =',nsrf, knon
+c
+c variables pour avoir une sortie IOIPSL des INDEX
+c
+      IF (debugindex) THEN 
+          tabindx(:)=0.
+c          tabindx(1:knon)=(/FLOAT(i),i=1:knon/)
+          DO i=1,knon
+            tabindx(1:knon)=FLOAT(i)
+          END DO 
+          debugtab(:,:)=0.
+          ndexbg(:)=0
+          CALL gath2cpl(tabindx,debugtab,klon,knon,iim,jjm,ni)
+          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1)
+     $        ,ndexbg)
+      ENDIF 
       IF (knon.EQ.0) GOTO 99999
       DO j = 1, knon
@@ -231,13 +375,43 @@
         ypct(j) = pctsrf(i,nsrf)
         yts(j) = ts(i,nsrf)
+        ysnow(j) = snow(i,nsrf)
+        yqsol(j) = qsol(i,nsrf)
+        yalb(j) = albe(i,nsrf)
+        yalblw(j) = alblw(i,nsrf)
+        yrain_f(j) = rain_f(i)
+        ysnow_f(j) = snow_f(i)
+        yagesno(j) = agesno(i,nsrf)
+        yfder(j) = fder(i)
+        ytaux(j) = flux_u(i,1,nsrf)
+        ytauy(j) = flux_v(i,1,nsrf)
+c$$$        ysolsw(j) = solsw(i)
+       ysolsw(j) = (1 - albe(i,nsrf)) 
+     $      /(1 - pctsrf(i,is_ter) * albe(i,is_ter) 
+     $      - pctsrf(i, is_lic) *albe(i,is_lic) 
+     $      - pctsrf(i, is_oce) *albe(i,is_oce)
+     $      - pctsrf(i, is_sic) *albe(i,is_sic) 
+     $      ) * solsw(i)
+        ysollw(j) = sollw(i)
+        ysollwdown(j) = sollwdown(i)
         yrugos(j) = rugos(i,nsrf)
+        yrugoro(j) = rugoro(i)
         yu1(j) = u1lay(i)
         yv1(j) = v1lay(i)
-        yrads(j) = totalflu(i)
-        ycal(j) = cal(i)
-        ybeta(j) = beta(i)
-        ydif(j) = dif_grnd(i)
+c$$$        yrads(j) = totalflu(i)
+        yrads(j) = (1 - albe(i,nsrf)) 
+     $      /(1 - pctsrf(i,is_ter) * albe(i,is_ter) 
+     $      - pctsrf(i, is_lic) *albe(i,is_lic) 
+     $      - pctsrf(i, is_oce) *albe(i,is_oce)
+     $      - pctsrf(i, is_sic) *albe(i,is_sic) 
+     $      ) * solsw(i) + sollw(i)
         ypaprs(j,klev+1) = paprs(i,klev+1)
-      ENDDO
+      END DO
+c$$$ PB ajour pour soil
+      DO k = 1, nsoilmx
+        DO j = 1, knon
+          i = ni(j)
+          ytsoil(j,k) = ftsoil(i,k,nsrf)
+        END DO  
+      END DO 
       DO k = 1, klev
       DO j = 1, knon
@@ -253,18 +427,4 @@
       ENDDO
 c
-cAA      IF (itr.GE.1) THEN
-cAA      DO it = 1, itr
-cAA        DO k = 1, klev
-cAA        DO j = 1, knon
-cAA        i = ni(j)
-cAA          ytr(j,k,it) = tr(i,k,it)
-cAA        ENDDO
-cAA        ENDDO
-cAA        DO j = 1, knon
-cAA        i = ni(j)
-cAA          yflxsrf(j,it) = flux_surf(i,it)
-cAA        ENDDO
-cAA      ENDDO
-cAA      ENDIF
 c
 c calculer Cdrag et les coefficients d'echange
@@ -272,39 +432,14 @@
      .            yts, yrugos, yu, yv, yt, yq,
      .            ycoefm, ycoefh)
-c
-c parametrisation non-locale:
-      IF (ok_nonloc) THEN
-         DO i = 1, knon
-            y_cd_h(i) = ycoefh(i,1)
-            y_cd_m(i) = ycoefm(i,1)
-         ENDDO
-         CALL nonlocal(knon, ypaprs, ypplay,
-     .        yts,ybeta,yu,yv,yt,yq,
-     .        y_cd_h, y_cd_m, ycoefm0, ycoefh0, ygamt, ygamq)
-         DO k = 1, klev
-         DO i = 1, knon
-            ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
-            ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
-         ENDDO
-         ENDDO
-      ELSE
-         DO k = 3, klev
-         DO i = 1, knon
-            ygamq(i,k) = 0.0
-            ygamt(i,k) = -1.0E-03
-         ENDDO
-         ENDDO
-         DO i = 1, knon
-            ygamq(i,2) = 0.0
-            ygamt(i,2) = -2.5E-03
-         ENDDO
-      ENDIF
-c
-c calculer la diffusion de "q" et de "h"
-      CALL clqh(knon, dtime, yu1, yv1,
-     e          ycoefh,yt,yq,yts,ypaprs,ypplay,ydelp,yrads,
-     e          ycal,ybeta,ydif,ygamt,ygamq,
-     s          y_d_t, y_d_q, y_d_ts, 
-     s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q)
+      CALL coefkz2(nsrf, knon, ypaprs, ypplay,yt,
+     .                  ycoefm0, ycoefh0)
+      DO k = 1, klev
+      DO i = 1, knon
+         ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+         ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+      ENDDO
+      ENDDO
+
+c
 c
 c calculer la diffusion des vitesses "u" et "v"
@@ -313,6 +448,28 @@
       CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yv,ypaprs,ypplay,ydelp,
      s            y_d_v,y_flux_v)
+
+c pour le couplage
+      ytaux = y_flux_u(:,1)
+      ytauy = y_flux_v(:,1)
+
+c calculer la diffusion de "q" et de "h"
+      CALL clqh(dtime, itap, date0,jour, debut,lafin,
+     e          rlon, rlat, cufi, cvfi,
+     e          knon, nsrf, ni, pctsrf,
+     e          soil_model, ytsoil,
+     e          ok_veget, ocean, npas, nexca,
+     e          rmu0, yrugos, yrugoro,
+     e          yu1, yv1, ycoefh,
+     e          yt,yq,yts,ypaprs,ypplay,
+     e          ydelp,yrads,yalb, yalblw, ysnow, yqsol, 
+     e          yrain_f, ysnow_f, yfder, ytaux, ytauy, 
+c$$$     e          ysollw, ysolsw,
+     e          ysollw, ysollwdown, ysolsw,yfluxlat,
+     s          pctsrf_new, yagesno,
+     s          y_d_t, y_d_q, y_d_ts, yz0_new,
+     s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q)
 c
 c calculer la longueur de rugosite sur ocean
+      yrugm=0.
       IF (nsrf.EQ.is_oce) THEN
       DO j = 1, knon
@@ -321,15 +478,4 @@
       ENDDO
       ENDIF
-c
-cAA MAINTENANT DANS PHYTRAC
-cAAc calculer la diffusion des traceurs
-cAA      IF (itr.GE.1) THEN
-cAA      DO it = 1, itr
-cAA      CALL cltrac(knon,dtime,ycoefh, yt, ytr(1,1,it), yflxsrf(1,it),
-cAA     e            ypaprs, ypplay, ydelp,
-cAA     s            y_d_tr(1,1,it))
-cAA      ENDDO
-cAA      ENDIF
-c
       DO j = 1, knon
          y_dflux_t(j) = y_dflux_t(j) * ypct(j)
@@ -340,22 +486,47 @@
 c
       DO k = 1, klev
+        DO j = 1, knon
+          i = ni(j)
+          ycoefh(j,k) = ycoefh(j,k) * ypct(j)
+          ycoefm(j,k) = ycoefm(j,k) * ypct(j)
+          y_d_t(j,k) = y_d_t(j,k) * ypct(j)
+          y_d_q(j,k) = y_d_q(j,k) * ypct(j)
+C§§§ PB
+          flux_t(i,k,nsrf) = y_flux_t(j,k)
+          flux_q(i,k,nsrf) = y_flux_q(j,k)
+          flux_u(i,k,nsrf) = y_flux_u(j,k)
+          flux_v(i,k,nsrf) = y_flux_v(j,k)
+c$$$ PB        y_flux_t(j,k) = y_flux_t(j,k) * ypct(j)
+c$$$ PB        y_flux_q(j,k) = y_flux_q(j,k) * ypct(j)
+          y_d_u(j,k) = y_d_u(j,k) * ypct(j)
+          y_d_v(j,k) = y_d_v(j,k) * ypct(j)
+c$$$ PB        y_flux_u(j,k) = y_flux_u(j,k) * ypct(j)
+c$$$ PB        y_flux_v(j,k) = y_flux_v(j,k) * ypct(j)
+        ENDDO
+      ENDDO
+
+
+      evap(:,nsrf) = - flux_q(:,1,nsrf)
+c
+      albe(:, nsrf) = 0.
+      alblw(:, nsrf) = 0.
+      snow(:, nsrf) = 0.
+      qsol(:, nsrf) = 0.
+      rugos(:, nsrf) = 0.
+      fluxlat(:,nsrf) = 0.
       DO j = 1, knon
-         ycoefh(j,k) = ycoefh(j,k) * ypct(j)
-         ycoefm(j,k) = ycoefm(j,k) * ypct(j)
-         y_d_t(j,k) = y_d_t(j,k) * ypct(j)
-         y_d_q(j,k) = y_d_q(j,k) * ypct(j)
-         y_flux_t(j,k) = y_flux_t(j,k) * ypct(j)
-         y_flux_q(j,k) = y_flux_q(j,k) * ypct(j)
-         y_d_u(j,k) = y_d_u(j,k) * ypct(j)
-         y_d_v(j,k) = y_d_v(j,k) * ypct(j)
-         y_flux_u(j,k) = y_flux_u(j,k) * ypct(j)
-         y_flux_v(j,k) = y_flux_v(j,k) * ypct(j)
-      ENDDO
-      ENDDO
-c
-      DO j = 1, knon
-      i = ni(j)
+         i = ni(j)
          d_ts(i,nsrf) = y_d_ts(j)
-         rugmer(i) = yrugm(j)
+         albe(i,nsrf) = yalb(j)
+         alblw(i,nsrf) = yalblw(j)
+         snow(i,nsrf) = ysnow(j)
+         qsol(i,nsrf) = yqsol(j)
+         rugos(i,nsrf) = yz0_new(j)
+         fluxlat(i,nsrf) = yfluxlat(j)
+c$$$ pb         rugmer(i) = yrugm(j)
+         IF (nsrf .EQ. is_oce) then 
+	       rugmer(i) = yrugm(j)
+               rugos(i,nsrf) = yrugm(i)
+          endif	
          cdragh(i) = cdragh(i) + ycoefh(j,1)
          cdragm(i) = cdragm(i) + ycoefm(j,1)
@@ -364,5 +535,13 @@
          zu1(i) = zu1(i) + yu1(j)
          zv1(i) = zv1(i) + yv1(j)
-      ENDDO
+      END DO
+c$$$ PB ajout pour soil
+      ftsoil(:,:,nsrf) = 0.
+      DO k = 1, nsoilmx
+        DO j = 1, knon
+          i = ni(j)
+          ftsoil(i, k, nsrf) = ytsoil(j,k)
+        END DO 
+      END DO 
 c
 #ifdef CRAY
@@ -377,39 +556,42 @@
          d_t(i,k) = d_t(i,k) + y_d_t(j,k)
          d_q(i,k) = d_q(i,k) + y_d_q(j,k)
-         flux_t(i,k) = flux_t(i,k) + y_flux_t(j,k)
-         flux_q(i,k) = flux_q(i,k) + y_flux_q(j,k)
+c$$$ PB        flux_t(i,k) = flux_t(i,k) + y_flux_t(j,k)
+c$$$         flux_q(i,k) = flux_q(i,k) + y_flux_q(j,k)
          d_u(i,k) = d_u(i,k) + y_d_u(j,k)
          d_v(i,k) = d_v(i,k) + y_d_v(j,k)
-         flux_u(i,k) = flux_u(i,k) + y_flux_u(j,k)
-         flux_v(i,k) = flux_v(i,k) + y_flux_v(j,k)
+c$$$  PB       flux_u(i,k) = flux_u(i,k) + y_flux_u(j,k)
+c$$$         flux_v(i,k) = flux_v(i,k) + y_flux_v(j,k)
          zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
       ENDDO
       ENDDO
 c
-cAA      IF (itr.GE.1) THEN
-cAA      DO it = 1, itr
-cAA      DO k = 1, klev
-cAA      DO j = 1, knon
-cAA         y_d_tr(j,k,it) = y_d_tr(j,k,it) * ypct(j)
-cAA      ENDDO
-cAA      ENDDO
-cAA      ENDDO
-cAA      DO j = 1, knon
-cAA      i = ni(j)
-cAA      DO it = 1, itr
-cAA      DO k = 1, klev
-cAA         d_tr(i,k,it) = d_tr(i,k,it) + y_d_tr(j,k,it)
-cAA      ENDDO
-cAA      ENDDO
-cAA      ENDDO
-cAA      ENDIF
-c
 99999 CONTINUE
 c
+C
+C On utilise les nouvelles surfaces
+C A rajouter: conservation de l'albedo
+C
+      rugos(:,is_oce) = rugmer
+      pctsrf = pctsrf_new
+
       RETURN
       END
-      SUBROUTINE clqh(knon,dtime,u1lay,v1lay,coef,t,q,ts,paprs,pplay,
-     e                delp,radsol,cal,beta,dif_grnd, gamt,gamq,
-     s                d_t, d_q, d_ts, flux_t, flux_q,dflux_s,dflux_l)
+      SUBROUTINE clqh(dtime,itime, date0,jour,debut,lafin,
+     e                rlon, rlat, cufi, cvfi, 
+     e                knon, nisurf, knindex, pctsrf,
+     $                soil_model,tsoil,
+     e                ok_veget, ocean, npas, nexca,
+     e                rmu0, rugos, rugoro,
+     e                u1lay,v1lay,coef,
+     e                t,q,ts,paprs,pplay,
+     e                delp,radsol,albedo,alblw,snow,qsol, 
+     e                precip_rain, precip_snow, fder, taux, tauy,
+     $                sollw, sollwdown, swnet,fluxlat, 
+     s                pctsrf_new, agesno,
+     s                d_t, d_q, d_ts, z0_new, 
+     s                flux_t, flux_q,dflux_s,dflux_l)
+
+      USE interface_surf
+
       IMPLICIT none
 c======================================================================
@@ -419,7 +601,13 @@
 #include "dimensions.h"
 #include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "indicesol.h"
+#include "dimsoil.h"
 c Arguments:
       INTEGER knon
       REAL dtime              ! intervalle du temps (s)
+      real date0
       REAL u1lay(klon)        ! vitesse u de la 1ere couche (m/s)
       REAL v1lay(klon)        ! vitesse v de la 1ere couche (m/s)
@@ -428,15 +616,29 @@
 c                               vent (dV/dz); la premiere valeur
 c                               indique la valeur de Cdrag (sans unite)
-      REAL cal(klon)          ! Cp/cal indique la capacite calorifique
-c                               surfacique du sol
-      REAL beta(klon)         ! evap. reelle / evapotranspiration
-      REAL dif_grnd(klon)     ! coeff. diffusion vers le sol profond
       REAL t(klon,klev)       ! temperature (K)
       REAL q(klon,klev)       ! humidite specifique (kg/kg)
       REAL ts(klon)           ! temperature du sol (K)
+      REAL evap(klon)         ! evaporation au sol
       REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
       REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
       REAL delp(klon,klev)    ! epaisseur de couche en pression (Pa)
       REAL radsol(klon)       ! ray. net au sol (Solaire+IR) W/m2
+      REAL albedo(klon)       ! albedo de la surface
+      REAL alblw(klon)
+      REAL snow(klon)         ! hauteur de neige
+      REAL qsol(klon)         ! humidite de la surface
+      real precip_rain(klon), precip_snow(klon)
+      REAL agesno(klon)
+      REAL rugoro(klon)
+      integer jour            ! jour de l'annee en cours
+      real rmu0(klon)         ! cosinus de l'angle solaire zenithal
+      real rugos(klon)        ! rugosite
+      integer knindex(klon)
+      real pctsrf(klon,nbsrf)
+      real rlon(klon), rlat(klon), cufi(klon), cvfi(klon)
+      logical ok_veget 
+      character*6 ocean
+      integer npas, nexca
+
 c
       REAL d_t(klon,klev)     ! incrementation de "t"
@@ -449,5 +651,4 @@
       REAL dflux_s(klon) ! derivee du flux sensible dF/dTs
       REAL dflux_l(klon) ! derivee du flux latent dF/dTs
-      REAL dflux_g(klon) ! derivee du flux du sol profond dF/dTs
 c======================================================================
       REAL t_grnd  ! temperature de rappel pour glace de mer
@@ -457,11 +658,4 @@
 c======================================================================
       INTEGER i, k
-      REAL zx_a
-      REAL zx_b
-      REAL zx_qs
-      REAL zx_dq_s_dh
-      REAL zx_h_grnd
-      REAL zx_cq0(klon)
-      REAL zx_dq0(klon)
       REAL zx_cq(klon,klev)
       REAL zx_dq(klon,klev)
@@ -471,11 +665,7 @@
       REAL zx_buf2(klon)
       REAL zx_coef(klon,klev)
-      REAL zx_q_0(klon)
-      REAL zx_h_ts(klon)
-      REAL zx_sl(klon)
       REAL local_h(klon,klev) ! enthalpie potentielle
       REAL local_q(klon,klev)
       REAL local_ts(klon)
-      REAL zx_alf1(klon), zx_alf2(klon) !valeur ambiante par extrapola.
       REAL psref(klon) ! pression de reference pour temperature potent.
       REAL zx_pkh(klon,klev), zx_pkf(klon,klev)
@@ -488,15 +678,54 @@
       REAL zdelz
 c======================================================================
-      REAL zcor, zdelta, zcvm5
-#include "YOMCST.h"
-#include "YOETHF.h"
-#include "FCTTRE.h"
-c======================================================================
+      logical contreg
+      parameter (contreg=.true.)
+c======================================================================
+c Rajout pour l'interface
+      integer itime
+      integer nisurf
+      logical debut, lafin
+      real zlev1(klon)
+      real fder(klon), taux(klon), tauy(klon)
+      real temp_air(klon), spechum(klon)
+      real epot_air(klon), ccanopy(klon)
+      real tq_cdrag(klon), petAcoef(klon), peqAcoef(klon)
+      real petBcoef(klon), peqBcoef(klon)
+      real sollw(klon), sollwdown(klon), swnet(klon), swdown(klon)
+      real p1lay(klon)
+c$$$C PB ajout pour soil
+      LOGICAL soil_model
+      REAL tsoil(klon, nsoilmx)
+
+! Parametres de sortie
+      real fluxsens(klon), fluxlat(klon)
+      real tsol_rad(klon), tsurf_new(klon), alb_new(klon)
+      real emis_new(klon), z0_new(klon)
+      real pctsrf_new(klon,nbsrf)
+      
+c
+
+      if (.not. contreg) then
+        do k = 2, klev
+          do i = 1, knon
+            gamq(i,k) = 0.0
+            gamt(i,k) = 0.0
+          enddo
+        enddo
+      else
+        do k = 3, klev
+          do i = 1, knon
+            gamq(i,k)= 0.0
+            gamt(i,k)=  -1.0e-03
+          enddo
+        enddo
+        do i = 1, knon
+          gamq(i,2) = 0.0
+          gamt(i,2) = -2.5e-03
+        enddo
+      endif
+
       DO i = 1, knon
          psref(i) = paprs(i,1) !pression de reference est celle au sol
          local_ts(i) = ts(i)
-ccc         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
-         zx_alf1(i) = 1.0
-         zx_alf2(i) = 1.0 - zx_alf1(i)
       ENDDO
       DO k = 1, klev
@@ -511,10 +740,4 @@
 c Convertir les coefficients en variables convenables au calcul:
 c
-      DO i = 1, knon
-         zx_coef(i,1) = coef(i,1)
-     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
-     .                 * pplay(i,1)/(RD*t(i,1))
-         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
-      ENDDO
 c
       DO k = 2, klev
@@ -535,31 +758,4 @@
          z_gamah(i,k) = gamt(i,k) * zdelz *RCPD * zx_pkh(i,k)
       ENDDO
-      ENDDO
-c======================================================================
-      DO i = 1, knon
-         IF (thermcep) THEN
-           zdelta=MAX(0.,SIGN(1.,rtt-local_ts(i)))
-           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
-           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
-           zx_qs= r2es * FOEEW(local_ts(i),zdelta)/paprs(i,1)
-           zx_qs=MIN(0.5,zx_qs)
-           zcor=1./(1.-retv*zx_qs)
-           zx_qs=zx_qs*zcor
-           zx_dq_s_dh = FOEDE(local_ts(i),zdelta,zcvm5,zx_qs,zcor)
-     .                 /RLVTT / zx_pkh(i,1)
-         ELSE
-           IF (local_ts(i).LT.t_coup) THEN
-              zx_qs = qsats(local_ts(i)) / paprs(i,1)
-              zx_dq_s_dh = dqsats(local_ts(i),zx_qs)/RLVTT
-     .                    / zx_pkh(i,1)
-           ELSE
-              zx_qs = qsatl(local_ts(i)) / paprs(i,1)
-              zx_dq_s_dh = dqsatl(local_ts(i),zx_qs)/RLVTT
-     .                    / zx_pkh(i,1)
-           ENDIF
-         ENDIF
-c
-         zx_dq0(i) = zx_dq_s_dh
-         zx_cq0(i) = zx_qs -zx_dq_s_dh *local_ts(i)*RCPD*zx_pkh(i,1)
       ENDDO
       DO i = 1, knon
@@ -593,60 +789,77 @@
       ENDDO
       ENDDO
+C
+C nouvelle formulation JL Dufresne
+C
+C q1 = zx_cq(i,1) + zx_dq(i,1) * Flux_Q(i,1) * dt
+C h1 = zx_ch(i,1) + zx_dh(i,1) * Flux_H(i,1) * dt
+C
       DO i = 1, knon
          zx_buf1(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dq(i,2))
-     .              + zx_coef(i,1)*beta(i)
-     .                *(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
          zx_cq(i,1) = (local_q(i,1)*delp(i,1)
-     .                 +zx_coef(i,2)*z_gamaq(i,2)
-     .                 +zx_cq(i,2)*(zx_coef(i,2)
-     .                  -zx_coef(i,1)*zx_alf2(i)*beta(i)) )
+     .                 +zx_coef(i,2)*(z_gamaq(i,2)+zx_cq(i,2)))
      .                /zx_buf1(i)
-         zx_dq(i,1) = beta(i) * zx_coef(i,1) / zx_buf1(i)
+         zx_dq(i,1) = -1. * RG / zx_buf1(i)
 c
          zx_buf2(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2))
-     .               +zx_coef(i,1)
-     .                *(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))
          zx_ch(i,1) = (local_h(i,1)*delp(i,1)
-     .                 +zx_coef(i,2)*z_gamah(i,2)
-     .                 +zx_ch(i,2)*(zx_coef(i,2)
-     .                  -zx_coef(i,1)*zx_alf2(i)) )
+     .                 +zx_coef(i,2)*(z_gamah(i,2)+zx_ch(i,2)))
      .                /zx_buf2(i)
-         zx_dh(i,1) = zx_coef(i,1) / zx_buf2(i)
-      ENDDO
-c==== calculer d'abord local_h(0) ============================
-      DO i = 1, knon
-         zx_sl(i) = RLVTT
-         if (local_ts(i) .LT. RTT) zx_sl(i) = RLSTT
-      ENDDO
-      DO i = 1, knon
-         zx_h_grnd = t_grnd * zx_pkh(i,1) *RCPD
-         zx_h_ts(i) = local_ts(i) * zx_pkh(i,1) *RCPD
-         zx_a = radsol(i)
-     .        + zx_coef(i,1)/(RG*dtime)*beta(i)*zx_sl(i)
-     .          *(zx_cq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
-     .            +zx_alf2(i)*zx_cq(i,2))
-     .        + zx_coef(i,1)/(RG*dtime)*beta(i)*zx_sl(i)
-     .          *((zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
-     .             -1.0)*zx_cq0(i))
-     .        + zx_coef(i,1)/(RG*dtime)/zx_pkh(i,1)
-     .          *(zx_ch(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))
-     .           +zx_alf2(i)*zx_ch(i,2))
-         zx_a = zx_h_ts(i) + dif_grnd(i)*dtime*zx_h_grnd
-     .                     + cal(i)*zx_pkh(i,1)*dtime * zx_a 
-         zx_b = zx_coef(i,1)/(RG*dtime) *beta(i)*zx_sl(i)*zx_dq0(i)
-     .          *(1.0-zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2)))
-     .        + zx_coef(i,1)/(RG*dtime)/zx_pkh(i,1)
-     .          *(1.0-zx_dh(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2)))
-         zx_b = 1.0 + dif_grnd(i)*dtime + cal(i)*zx_pkh(i,1)*dtime*zx_b
-         zx_h_ts(i) = zx_a / zx_b
-         local_ts(i) = zx_h_ts(i) / zx_pkh(i,1)/RCPD
-      ENDDO
+         zx_dh(i,1) = -1. * RG / zx_buf2(i)
+      ENDDO
+
+C Appel a interfsurf (appel generique) routine d'interface avec la surface
+
+c initialisation
+       petAcoef =0. 
+	peqAcoef = 0.
+	petBcoef =0.
+	peqBcoef = 0.
+	p1lay =0.
+	
+c      do i = 1, knon
+        petAcoef(1:knon) = zx_ch(1:knon,1)
+        peqAcoef(1:knon) = zx_cq(1:knon,1)
+        petBcoef(1:knon) =  zx_dh(1:knon,1)
+        peqBcoef(1:knon) = zx_dq(1:knon,1)
+        tq_cdrag(1:knon) =coef(1:knon,1)
+        temp_air(1:knon) =t(1:knon,1)
+        epot_air(1:knon) =local_h(1:knon,1)
+        spechum(1:knon)=q(1:knon,1)
+        p1lay(1:knon) = pplay(1:knon,1)
+        zlev1(1:knon) = delp(1:knon,1)
+c        swnet = swdown * (1. - albedo)
+        swdown(1:knon) = swnet(1:knon)
+c      enddo
+c En attendant mieux
+      ccanopy = 365.
+
+      CALL interfsurf(itime, dtime, date0, jour, rmu0,
+     e klon, iim, jjm, nisurf, knon, knindex, pctsrf, 
+     e rlon, rlat, cufi, cvfi, 
+     e debut, lafin, ok_veget, soil_model, nsoilmx,tsoil,
+     e zlev1,  u1lay, v1lay, temp_air, spechum, epot_air, ccanopy, 
+     e tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef,
+     e precip_rain, precip_snow, sollw, sollwdown, swnet, swdown,
+     e fder, taux, tauy, rugos, rugoro,
+     e albedo, snow, qsol,
+     e ts, p1lay, psref, radsol,
+     e ocean, npas, nexca, zmasq,
+     s evap, fluxsens, fluxlat, dflux_l, dflux_s,              
+     s tsol_rad, tsurf_new, alb_new, alblw, emis_new, z0_new, 
+     s pctsrf_new, agesno)
+
+
+      do i = 1, knon
+        flux_t(i,1) = fluxsens(i)
+        flux_q(i,1) = - evap(i)
+        d_ts(i) = tsurf_new(i) - ts(i)
+        albedo(i) = alb_new(i)
+      enddo
+
 c==== une fois on a zx_h_ts, on peut faire l'iteration ========
       DO i = 1, knon
-         zx_q_0(i) = zx_cq0(i) + zx_dq0(i)*zx_h_ts(i)
-      ENDDO
-      DO i = 1, knon
-         local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*zx_h_ts(i)
-         local_q(i,1) = zx_cq(i,1) + zx_dq(i,1)*zx_q_0(i)
+         local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*flux_t(i,1)*dtime
+         local_q(i,1) = zx_cq(i,1) + zx_dq(i,1)*flux_q(i,1)*dtime
       ENDDO
       DO k = 2, klev
@@ -659,13 +872,4 @@
 c== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
 c== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
-      DO i = 1, knon
-        flux_q(i,1) = (zx_coef(i,1)/dtime/RG) * beta(i)
-     .              * (local_q(i,1)*zx_alf1(i)
-     .                +local_q(i,2)*zx_alf2(i)-zx_q_0(i))
-        flux_t(i,1) = (zx_coef(i,1)/dtime/RG)
-     .              * (local_h(i,1)*zx_alf1(i)
-     .                +local_h(i,2)*zx_alf2(i)-zx_h_ts(i))
-     .              / zx_pkh(i,1)
-      ENDDO
       DO k = 2, klev
       DO i = 1, knon
@@ -678,14 +882,5 @@
       ENDDO
 c======================================================================
-c Derives des flux dF/dTs (W m-2 K-1):
-      DO i = 1, knon
-         dflux_s(i) = (RCPD*zx_coef(i,1))/(RG*dtime)/zx_pkh(i,1)
-     .         *(zx_dh(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))-1.0)
-         dflux_l(i) = (beta(i)*RLVTT*RCPD*zx_coef(i,1))/(RG*dtime)
-     .         *zx_dq0(i)
-     .         *(zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))-1.0)
-         dflux_g(i) = dif_grnd(i) * RCPD
-      ENDDO
-c======================================================================
+C Calcul tendances
       DO k = 1, klev
       DO i = 1, knon
@@ -694,8 +889,6 @@
       ENDDO
       ENDDO
-      DO i = 1, knon
-         d_ts(i) = local_ts(i) - ts(i)
-      ENDDO
-c
+c
+
       RETURN
       END
@@ -836,5 +1029,4 @@
 c ts-------input-R- temperature du sol (en Kelvin)
 c rugos----input-R- longeur de rugosite (en m)
-c xlat-----input-R- latitude en degree
 c u--------input-R- vitesse u
 c v--------input-R- vitesse v
@@ -858,5 +1050,4 @@
       REAL u(klon,klev), v(klon,klev), t(klon,klev), q(klon,klev)
       REAL rugos(klon)
-      REAL xlat(klon)
 c
       REAL pcfm(klon,klev), pcfh(klon,klev)
@@ -873,5 +1064,5 @@
       PARAMETER (clam=160.0)
       REAL ratqs ! largeur de distribution de vapeur d'eau
-      PARAMETER (ratqs=0.2)
+      PARAMETER (ratqs=0.05)
       LOGICAL richum ! utilise le nombre de Richardson humide
       PARAMETER (richum=.TRUE.)
@@ -881,5 +1072,5 @@
       PARAMETER (prandtl=0.4)
       REAL kstable ! diffusion minimale (situation stable)
-      PARAMETER (kstable=1.0e-06)
+      PARAMETER (kstable=1.0e-10)
       REAL mixlen ! constante controlant longueur de melange
       PARAMETER (mixlen=35.0)
@@ -911,4 +1102,7 @@
 c contre-gradient pour la chaleur sensible: Kelvin/metre
       REAL gamt(2:klev)
+c essai qsurf
+      real qsurf(klon)
+      real friv, frih
 c
       LOGICAL appel1er
@@ -947,8 +1141,13 @@
          itop(i) = 0
       ENDDO
+
+      do i = 1, knon
+        qsurf(i) = qsatl(ts(i))/paprs(i,1)
+      enddo
+
 c
 c Prescrire la valeur de contre-gradient
 c
-      IF (contreg) THEN
+      IF (.NOT.contreg) THEN
          DO k = 2, klev
             gamt(k) = 0.0
@@ -980,5 +1179,6 @@
          zdu2=max(cepdu2,u(i,1)**2+v(i,1)**2)
          zdphi=zgeop(i,1)
-         ztsolv = ts(i) * (1.0+RETV*q(i,1)) ! qsol approx = q(i,1)
+c         ztsolv = ts(i) * (1.0+RETV*q(i,1)) ! qsol approx = q(i,1)
+         ztsolv = ts(i) * (1.0+RETV*qsurf(i))
          ztvd=(t(i,1)+zdphi/RCPD/(1.+RVTMP2*q(i,1)))
      .       *(1.+RETV*q(i,1))
@@ -988,6 +1188,10 @@
            IF (.NOT.zxli) THEN
            zscf=SQRT(1.+cd*ABS(zri(i)))
-           zcfm1(i) = zcdn/(1.+2.0*cb*zri(i)/zscf)
-           zcfh1(i) = zcdn/(1.+3.0*cb*zri(i)*zscf)
+           FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+!           zcfm1(i) = zcdn/(1.+2.0*cb*zri(i)/ zscf)
+           zcfm1(i) = zcdn * FRIV
+           FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+!           zcfh1(i) = zcdn/(1.+3.0*cb*zri(i)*zscf)
+           zcfh1(i) = zcdn * FRIH
            pcfm(i,1) = zcfm1(i)
            pcfh(i,1) = zcfh1(i)
@@ -1000,6 +1204,6 @@
            zucf=1./(1.+3.0*cb*cc*zcdn*SQRT(ABS(zri(i))
      .              *(1.0+zgeop(i,1)/(RG*rugos(i)))))
-           zcfm2(i) = zcdn*(1.-2.0*cb*zri(i)*zucf)
-           zcfh2(i) = zcdn*(1.-3.0*cb*zri(i)*zucf)
+           zcfm2(i) = zcdn*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+           zcfh2(i) = zcdn*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
            pcfm(i,1) = zcfm2(i)
            pcfh(i,1) = zcfh2(i)
@@ -1012,4 +1216,5 @@
          ENDIF
       ENDDO
+
 c
 c Calculer les coefficients turbulents dans l'atmosphere
@@ -1131,5 +1336,102 @@
       RETURN
       END
-      SUBROUTINE calbeta(dtime,indice,snow,qsol,
+      SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t,
+     .                  pcfm, pcfh)
+      IMPLICIT none
+c======================================================================
+c J'introduit un peu de diffusion sauf dans les endroits
+c ou une forte inversion est presente
+c On peut dire qu'il represente la convection peu profonde
+c
+c Arguments:
+c nsrf-----input-I- indicateur de la nature du sol
+c knon-----input-I- nombre de points a traiter
+c paprs----input-R- pression a chaque intercouche (en Pa)
+c pplay----input-R- pression au milieu de chaque couche (en Pa)
+c t--------input-R- temperature (K)
+c
+c pcfm-----output-R- coefficients a calculer (vitesse)
+c pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c
+c Arguments:
+c
+      INTEGER knon, nsrf
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+c Quelques constantes et options:
+c
+      REAL prandtl
+      PARAMETER (prandtl=0.4)
+      REAL kstable
+      PARAMETER (kstable=0.002)
+ccc      PARAMETER (kstable=0.001)
+      REAL mixlen ! constante controlant longueur de melange
+      PARAMETER (mixlen=35.0)
+      REAL seuil ! au-dela l'inversion est consideree trop faible
+      PARAMETER (seuil=-0.02)
+ccc      PARAMETER (seuil=-0.04)
+ccc      PARAMETER (seuil=-0.06)
+ccc      PARAMETER (seuil=-0.09)
+c
+c Variables locales:
+c
+      INTEGER i, k, invb(knon)
+      REAL zl2(knon)
+      REAL zdthmin(knon), zdthdp
+c
+c Initialiser les sorties
+c
+      DO k = 1, klev
+      DO i = 1, knon
+         pcfm(i,k) = 0.0
+         pcfh(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Chercher la zone d'inversion forte
+c
+      DO i = 1, knon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+      DO k = 2, klev/2-1
+      DO i = 1, knon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
+     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * 100.0
+         IF (pplay(i,k).GT.0.8*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Introduire une diffusion:
+c
+      DO k = 2, klev
+      DO i = 1, knon
+      IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+     .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+     .     (zdthmin(i).GT.seuil) )THEN ! si l'inversion est trop faible
+         zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1))
+     .                       /(paprs(i,2)-paprs(i,klev+1)) ))**2
+         pcfm(i,k)= zl2(i)* kstable
+         pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE calbeta(dtime,indice,knon,snow,qsol,
      .                    vbeta,vcal,vdif)
       IMPLICIT none
@@ -1146,5 +1448,6 @@
 #include "indicesol.h"
       REAL tau_gl ! temps de relaxation pour la glace de mer
-      PARAMETER (tau_gl=86400.0*30.0)
+ccc      PARAMETER (tau_gl=86400.0*30.0)
+      PARAMETER (tau_gl=86400.0*5.0)
       REAL mx_eau_sol
       PARAMETER (mx_eau_sol=150.0)
@@ -1158,6 +1461,6 @@
 c
       REAL dtime
-      REAL snow(klon,nbsrf), qsol(klon,nbsrf)
-      INTEGER indice
+      REAL snow(klon), qsol(klon)
+      INTEGER indice, knon
 C
       REAL vbeta(klon)
@@ -1165,6 +1468,7 @@
       REAL vdif(klon)
 C
+
       IF (indice.EQ.is_oce) THEN
-      DO i = 1, klon
+      DO i = 1, knon
           vcal(i)   = 0.0
           vbeta(i)  = 1.0
@@ -1174,18 +1478,18 @@
 c
       IF (indice.EQ.is_sic) THEN
-      DO i = 1, klon
+      DO i = 1, knon
           vcal(i) = calice
-          IF (snow(i,is_sic) .GT. 0.0) vcal(i) = calsno
+          IF (snow(i) .GT. 0.0) vcal(i) = calsno
           vbeta(i)  = 1.0
-ccc          vdif(i) = 1.0/tau_gl ! c'etait une erreur
-          vdif(i) = calice/tau_gl
+          vdif(i) = 1.0/tau_gl
+ccc          vdif(i) = calice/tau_gl ! c'etait une erreur
       ENDDO
       ENDIF
 c
       IF (indice.EQ.is_ter) THEN
-      DO i = 1, klon
+      DO i = 1, knon
           vcal(i) = calsol
-          IF (snow(i,is_ter) .GT. 0.0) vcal(i) = calsno
-          vbeta(i)  = MIN(2.0*qsol(i,is_ter)/mx_eau_sol, 1.0)
+          IF (snow(i) .GT. 0.0) vcal(i) = calsno
+          vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
           vdif(i) = 0.0
       ENDDO
@@ -1193,7 +1497,7 @@
 c
       IF (indice.EQ.is_lic) THEN
-      DO i = 1, klon
+      DO i = 1, knon
           vcal(i) = calice
-          IF (snow(i,is_lic) .GT. 0.0) vcal(i) = calsno
+          IF (snow(i) .GT. 0.0) vcal(i) = calsno
           vbeta(i)  = 1.0
           vdif(i) = 0.0
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/condsurf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/condsurf.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/condsurf.F	(revision 300)
@@ -1,2 +1,4 @@
+c $Header$
+c
       SUBROUTINE condsurf( jour, jourvrai, pctsrf,
      s                    lmt_sst,lmt_alb,lmt_rug,lmt_bils )
@@ -31,5 +33,5 @@
 
       LOGICAL newlmt
-      PARAMETER (newlmt=.FALSE.)
+      PARAMETER (newlmt=.TRUE.)
 
       INTEGER     nannemax
@@ -43,9 +45,4 @@
       REAL lmt_rug(klon) ! longeur de rugosite du sol
       REAL lmt_bils(klon)
-c
-c Couplage OASIS:
-#include "oasis.h"
-      REAL cpl_sst(iim,jjm+1), cpl_sic(iim,jjm+1)
-      REAL cpl_alb_sst(iim,jjm+1), cpl_alb_sic(iim,jjm+1)
 c
 c Variables locales:
@@ -119,21 +116,23 @@
       IF (newlmt) THEN
 c
-c Fraction "ocean":
-      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "condsurf: Le champ <FOCE> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_oce))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_oce))
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "condsurf: Lecture echouee pour <FOCE>"
-         CALL abort
-      ENDIF
+c$$$c Fraction "ocean":
+c$$$      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+c$$$      IF (ierr .NE. NF_NOERR) THEN
+c$$$         PRINT*, "condsurf: Le champ <FOCE> est absent"
+c$$$         CALL abort
+c$$$      ENDIF
+c$$$#ifdef NC_DOUBLE
+c$$$      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_oce))
+c$$$#else
+c$$$      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_oce))
+c$$$#endif
+c$$$      IF (ierr .NE. NF_NOERR) THEN
+c$$$         PRINT*, "condsurf: Lecture echouee pour <FOCE>"
+c$$$         CALL abort
+c$$$      ENDIF
 c
 c Fraction "glace de mer":
+c
+c
       ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
       IF (ierr .NE. NF_NOERR) THEN
@@ -150,36 +149,54 @@
          CALL abort
       ENDIF
-c
-c Fraction "terre":
-      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "condsurf: Le champ <FTER> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_ter))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_ter))
-#endif
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "condsurf: Lecture echouee pour <FTER>"
-         CALL abort
-      ENDIF
-c
-c Fraction "glacier terre":
-      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
-      IF (ierr .NE. NF_NOERR) THEN
-         PRINT*, "condsurf: Le champ <FLIC> est absent"
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_lic))
-#else
-      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_lic))
-#endif
-      IF (ierr .NE. 0) THEN
-         PRINT*, "condsurf: Lecture echouee pour <FLIC>"
-         CALL abort
-      ENDIF
+C 
+C positionnement % ocean libre et verification qu'il y a compatibilite des soussurfaces
+      pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon)) 
+     $    - pctsrf(1 : klon, is_sic)
+      DO i = 1, klon
+        IF ( pctsrf(i, is_sic) .GT. (1. - zmasq(i)) ) THEN
+            WRITE(*,*) 'condsurf : sea-ice et masque pb en ', i,
+     $     pctsrf(i, is_sic), (1. - zmasq(i))     
+            pctsrf(i, is_sic) = (1. - zmasq(i))
+            pctsrf(i, is_oce) = 0.
+        ENDIF          
+        IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
+     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
+     $       THEN 
+             WRITE(*,*) 'condsurf : pb sous surface au point ', i, 
+     $           pctsrf(i, 1 : nbsrf)
+         ENDIF 
+      END DO 
+c
+c$$$c Fraction "terre":
+c$$$      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+c$$$      IF (ierr .NE. NF_NOERR) THEN
+c$$$         PRINT*, "condsurf: Le champ <FTER> est absent"
+c$$$         CALL abort
+c$$$      ENDIF
+c$$$#ifdef NC_DOUBLE
+c$$$      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_ter))
+c$$$#else
+c$$$      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_ter))
+c$$$#endif
+c$$$      IF (ierr .NE. NF_NOERR) THEN
+c$$$         PRINT*, "condsurf: Lecture echouee pour <FTER>"
+c$$$         CALL abort
+c$$$      ENDIF
+c$$$c
+c$$$c Fraction "glacier terre":
+c$$$      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+c$$$      IF (ierr .NE. NF_NOERR) THEN
+c$$$         PRINT*, "condsurf: Le champ <FLIC> est absent"
+c$$$         CALL abort
+c$$$      ENDIF
+c$$$#ifdef NC_DOUBLE
+c$$$      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_lic))
+c$$$#else
+c$$$      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_lic))
+c$$$#endif
+c$$$      IF (ierr .NE. 0) THEN
+c$$$         PRINT*, "condsurf: Lecture echouee pour <FLIC>"
+c$$$         CALL abort
+c$$$      ENDIF
 c
       ELSE ! test sur newlmt
@@ -299,52 +316,4 @@
       PRINT*, 'SST, ALB, RUG, etc. sont lus pour jour: ', jour
 c
-      IF (ok_oasis) THEN
-C
-         CALL fromcpl(jour,(jjm+1)*iim,
-     .        cpl_sst,cpl_sic,cpl_alb_sst,cpl_alb_sic)
-         DO i = 1, iim-1 ! un seul point pour le pole nord
-            cpl_sst(i,1) = cpl_sst(iim,1)
-            cpl_sic(i,1) = cpl_sic(iim,1)
-            cpl_alb_sst(i,1) = cpl_alb_sst(iim,1)
-            cpl_alb_sic(i,1) = cpl_alb_sic(iim,1)
-         ENDDO
-         DO i = 2, iim ! un seul point pour le pole sud
-            cpl_sst(i,jjm+1) = cpl_sst(1,jjm+1)
-            cpl_sic(i,jjm+1) = cpl_sic(1,jjm+1)
-            cpl_alb_sst(i,jjm+1) = cpl_alb_sst(1,jjm+1)
-            cpl_alb_sic(i,jjm+1) = cpl_alb_sic(1,jjm+1)
-         ENDDO
-c
-         ig = 1
-         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
-     .       pctsrf(ig,is_sic).GT.epsfra) THEN
-            pctsrf(ig,is_oce) = pctsrf(ig,is_oce)
-     .                        - (cpl_sic(1,1)-pctsrf(ig,is_sic))
-            pctsrf(ig,is_sic) = cpl_sic(1,1)
-            lmt_sst(ig) = cpl_sst(1,1)
-         ENDIF
-         DO j = 2, jjm
-         DO i = 1, iim
-         ig = ig + 1
-         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
-     .       pctsrf(ig,is_sic).GT.epsfra) THEN
-           pctsrf(ig,is_oce) = pctsrf(ig,is_oce) 
-     .                       - (cpl_sic(i,j)-pctsrf(ig,is_sic))
-           pctsrf(ig,is_sic) = cpl_sic(i,j)
-           lmt_sst(ig) = cpl_sst(i,j)
-         ENDIF
-         ENDDO
-         ENDDO
-         ig = ig + 1
-         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
-     .       pctsrf(ig,is_sic).GT.epsfra) THEN
-            pctsrf(ig,is_oce) = pctsrf(ig,is_oce)
-     .                        - (cpl_sic(1,jjm+1)-pctsrf(ig,is_sic))
-            pctsrf(ig,is_sic) = cpl_sic(1,jjm+1)
-            lmt_sst(ig) = cpl_sst(1,jjm+1)
-         ENDIF
-c
-      ENDIF ! ok_oasis
-c
       RETURN
       END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/conema3.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/conema3.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/conema3.F	(revision 300)
@@ -0,0 +1,281 @@
+c $Header$
+      SUBROUTINE conema (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,bas,top,Ma,cape,tvp,rflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c Mai 1998: Interface modifiee pour implementation dans LMDZ
+c======================================================================
+c Arguments:
+c dtime---input-R-pas d'integration (s)
+c paprs---input-R-pression inter-couches (Pa)
+c pplay---input-R-pression au milieu des couches (Pa)
+c t-------input-R-temperature (K)
+c q-------input-R-humidite specifique (kg/kg)
+c u-------input-R-vitesse du vent zonal (m/s)
+c v-------input-R-vitesse duvent meridien (m/s)
+c tra-----input-R-tableau de rapport de melange des traceurs
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c
+C d_t-----output-R-increment de la temperature
+c d_q-----output-R-increment de la vapeur d'eau
+c d_u-----output-R-increment de la vitesse zonale
+c d_v-----output-R-increment de la vitesse meridienne
+c d_tra---output-R-increment du contenu en traceurs
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c kbas----output-R-bas du nuage (integer)
+c ktop----output-R-haut du nuage (integer)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwdbis-output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c bas-----output-R-bas du nuage (real)
+c top-----output-R-haut du nuage (real)
+c Ma------output-R-flux ascendant non dilue (kg/m**2/s)
+c cape----output-R-CAPE
+c tvp-----output-R-virtual temperature of the lifted parcel
+c rflag---output-R-flag sur le fonctionnement de convect
+c pbase---output-R-pression a la base du nuage (Pa)
+c bbase---output-R-buoyancy a la base du nuage (K)
+c dtvpdt1-output-R-derivative of parcel virtual temp wrt T1 
+c dtvpdq1-output-R-derivative of parcel virtual temp wrt Q1 
+c dplcldt-output-R-derivative of the PCP pressure wrt T1
+c dplcldr-output-R-derivative of the PCP pressure wrt Q1
+c======================================================================
+c
+#include "dimensions.h"
+#include "dimphy.h"
+      INTEGER i, l,m,itra
+      INTEGER ntra,ntrac !number of tracers; if no tracer transport
+                         ! is needed, set ntra = 1 (or 0)
+      PARAMETER (ntrac=nqmx-2)
+      REAL dtime
+c
+
+c 
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), d_t(klon,klev), d_q(klon,klev)
+      REAL u(klon,klev), v(klon,klev), tra(klon,klev,ntra)
+      REAL d_u(klon,klev), d_v(klon,klev), d_tra(klon,klev,ntra)
+      REAL work1(klon,klev), work2(klon,klev)
+      REAL upwd(klon,klev), dnwd(klon,klev), dnwdbis(klon,klev)
+      REAL rain(klon)
+      REAL snow(klon)
+      REAL cape(klon), tvp(klon,klev), rflag(klon)
+      REAL pbase(klon), bbase(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+      INTEGER kbas(klon), ktop(klon)
+c
+      REAL em_t(klev)
+      REAL em_q(klev)
+      REAL em_qs(klev)
+      REAL em_u(klev), em_v(klev), em_tra(klev,ntrac)
+      REAL em_ph(klev+1), em_p(klev)
+      REAL em_work1(klev), em_work2(klev)
+      REAL em_precip, em_d_t(klev), em_d_q(klev)
+      REAL em_d_u(klev), em_d_v(klev), em_d_tra(klev,ntrac)
+      REAL em_upwd(klev), em_dnwd(klev), em_dnwdbis(klev)
+      REAL em_dtvpdt1(klev), em_dtvpdq1(klev)
+      REAL em_dplcldt, em_dplcldr
+      SAVE em_t,em_q, em_qs, em_ph, em_p, em_work1, em_work2
+      SAVE em_u,em_v, em_tra
+      SAVE em_d_u,em_d_v, em_d_tra
+      SAVE em_precip, em_d_t, em_d_q, em_upwd, em_dnwd, em_dnwdbis
+      INTEGER em_bas, em_top
+      SAVE em_bas, em_top
+c
+      REAL zx_t, zx_qs, zdelta, zcor
+      INTEGER iflag
+      REAL sigsum
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     VARIABLES A SORTIR
+cccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+      REAL emmip(klev) !variation de flux ascnon dilue i et i+1
+      SAVE emmip
+      real emMke(klev)
+      save emMke
+      real top
+      real bas
+      real emMa(klev)
+      save emMa
+      real Ma(klon,klev)
+      real Ment(klev,klev)
+      real Qent(klev,klev)
+      real TPS(klev),TLS(klev)
+      real SIJ(klev,klev)
+      real em_CAPE, em_TVP(klev)
+      real em_pbase, em_bbase
+      integer iw,j,k,ix,iy
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+ 
+c
+c$$$      print*,'debut conema'
+
+      DO 999 i = 1, klon
+      DO l = 1, klev+1
+         em_ph(l) = paprs(i,l) / 100.0
+      ENDDO
+c
+      DO l = 1, klev
+         em_p(l) = pplay(i,l) / 100.0
+         em_t(l) = t(i,l)
+         em_q(l) = q(i,l)
+         em_u(l) = u(i,l)
+         em_v(l) = v(i,l)
+         do itra = 1, ntra
+          em_tra(l,itra) = tra(i,l,itra)
+         enddo
+c$$$      print*,'em_t',em_t
+c$$$      print*,'em_q',em_q
+c$$$      print*,'em_qs',em_qs
+c$$$      print*,'em_u',em_u
+c$$$      print*,'em_v',em_v
+c$$$      print*,'em_tra',em_tra
+c$$$      print*,'em_p',em_p
+
+ 
+c
+         zx_t = em_t(l)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(l)/100.0
+         zx_qs=MIN(0.5,zx_qs)
+c$$$       print*,'zx_qs',zx_qs
+         zcor=1./(1.-retv*zx_qs) 
+         zx_qs=zx_qs*zcor
+         em_qs(l) = zx_qs
+c$$$      print*,'em_qs',em_qs
+c
+         em_work1(l) = work1(i,l)
+         em_work2(l) = work2(i,l)
+         emMke(l)=0
+c        emMa(l)=0
+c        Ma(i,l)=0
+     
+         em_dtvpdt1(l) = 0.
+         em_dtvpdq1(l) = 0.
+         dtvpdt1(i,l) = 0.
+         dtvpdq1(i,l) = 0.
+      ENDDO
+c
+      em_dplcldt = 0.
+      em_dplcldr = 0.
+      rain(i) = 0.0
+      snow(i) = 0.0
+      kbas(i) = 1
+      ktop(i) = 1
+c ajout SB:
+      bas = 1
+      top = 1
+ 
+ 
+c sb3d      write(*,1792) (em_work1(m),m=1,klev)
+1792  format('sig avant convect ',/,10(1X,E13.5))
+c
+c sb d      write(*,1793) (em_work2(m),m=1,klev)
+1793  format('w avant convect ',/,10(1X,E13.5))
+ 
+c$$$      print*,'avant convect' 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c 
+      CALL convect(dtime, em_t, em_q, em_qs,em_u ,em_v ,
+     .              em_tra, em_p, em_ph,
+     .              klev, klev+1, klev-1,ntra, dtime, iflag,
+     .              em_d_t, em_d_q,em_d_u,em_d_v,
+     .              em_d_tra, em_precip,
+     .              em_bas, em_top,em_upwd, em_dnwd, em_dnwdbis,
+     .              em_work1, em_work2,emmip,emMke,emMa,Ment,
+c SB 11sept98     .              Qent,TPS,TLS,SIJ)
+c 19oct98     .              Qent,TPS,TLS,SIJ,em_CAPE,em_TVP)
+     .  Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase,
+     .  em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr)
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c SB:
+      if (iflag.ne.1 .and. iflag.ne.4) then
+         em_CAPE = 0.
+      do l = 1, klev
+         em_upwd(l) = 0.
+         em_dnwd(l) = 0.
+         em_dnwdbis(l) = 0.
+         emMa(l) = 0.
+         em_TVP(l) = 0.
+      enddo
+      endif
+c fin SB
+c
+c  If sig has been set to zero, then set Ma to zero
+c
+      sigsum = 0.
+      do k = 1,klev
+        sigsum = sigsum + em_work1(k)
+      enddo
+      if (sigsum .eq. 0.0) then
+        do k = 1,klev
+          emMa(k) = 0.
+        enddo
+      endif
+c
+c sb3d       print*,'i, iflag=',i,iflag
+c 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c       SORTIE DES ICB ET INB
+c       en fait inb et icb correspondent au niveau ou se trouve
+c       le nuage,le numero d'interface
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+c modif SB:
+      if (iflag.EQ.1 .or. iflag.EQ.4) then
+       top=em_top
+       bas=em_bas
+       kbas(i) = em_bas
+       ktop(i) = em_top
+      endif
+ 
+      pbase(i) = em_pbase
+      bbase(i) = em_bbase
+      rain(i) = em_precip/ 86400.0
+      snow(i) = 0.0
+      cape(i) = em_CAPE
+      rflag(i) = float(iflag)
+c SB      kbas(i) = em_bas
+c SB      ktop(i) = em_top
+      dplcldt(i) = em_dplcldt
+      dplcldr(i) = em_dplcldr
+      DO l = 1, klev
+         d_t(i,l) = dtime * em_d_t(l) 
+         d_q(i,l) = dtime * em_d_q(l)
+         d_u(i,l) = dtime * em_d_u(l)
+         d_v(i,l) = dtime * em_d_v(l)
+         do itra = 1, ntra
+         d_tra(i,l,itra) = dtime * em_d_tra(l,itra)
+         enddo
+         upwd(i,l) = em_upwd(l)
+         dnwd(i,l) = em_dnwd(l)
+         dnwdbis(i,l) = em_dnwdbis(l)
+         work1(i,l) = em_work1(l)
+         work2(i,l) = em_work2(l)
+         Ma(i,l)=emMa(l)
+         tvp(i,l)=em_TVP(l)
+         dtvpdt1(i,l) = em_dtvpdt1(l)
+         dtvpdq1(i,l) = em_dtvpdq1(l)
+      ENDDO
+  999 CONTINUE
+ 
+
+      RETURN
+      END
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/conemav.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/conemav.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/conemav.F	(revision 300)
@@ -0,0 +1,147 @@
+      SUBROUTINE conemav (dtime,paprs,pplay,t,q,u,v,tra,ntra,
+     .             work1,work2,d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop,
+     .             upwd,dnwd,dnwdbis,Ma,cape,tvp,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+ 
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Cape----output-R-CAPE (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c======================================================================
+c
+#include "dimensions.h"
+#include "dimphy.h"
+c
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL tra(klon,klev,ntrac)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL d_tra(klon,klev,ntrac)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+       REAL Ma(klon,klev),cape(klon),tvp(klon,klev)
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+c
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev)
+       REAL cbmf(klon)
+       SAVE cbmf
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c
+      IF (ifrst .EQ. 0) THEN
+         ifrst = 1
+         DO i = 1, klon
+          cbmf(i) = 0.
+         ENDDO
+      ENDIF
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+
+c
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+c
+      noff = 2
+      minorig = 2
+      CALL convect1(klon,klev,klev+1,noff,minorig,t,q,qs,u,v,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,rain,cbmf,dtime,Ma)
+c
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+c      call dump2d(iim,jjm-1,rflag(2:klon-1),'FLAG CONVECTION   ')
+c     if (klon.eq.1) then
+c        print*,'IFLAG ',iflag
+c     else
+c        write(*,'(96i1)') (iflag(i),i=2,klon-1)
+c     endif
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+        DO itra = 1,ntra
+          DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+          ENDDO
+        ENDDO
+      ENDDO
+ 
+c
+c
+c
+      RETURN
+      END
+ 
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/conf_phys.F90
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/conf_phys.F90	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/conf_phys.F90	(revision 300)
@@ -0,0 +1,97 @@
+!
+! $Header$
+!
+
+  subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan)
+
+   use IOIPSL
+   implicit none
+
+!
+! Configuration de la "physique" de LMDZ a l'aide de la fonction
+! GETIN de IOIPSL
+!
+! LF 05/2001
+!
+
+!
+! ocean:      type d'ocean (force, slab, couple)
+! ok_veget:   type de modele de vegetation
+! ok_journe:  sorties journalieres
+! ok_mensuel: sorties mensuelles
+! ok_instan:  sorties instantanees
+
+
+
+! Sortie:
+  character (len = 6)  :: ocean
+  logical              :: ok_veget
+  logical              :: ok_journe, ok_mensuel, ok_instan
+! Local
+  integer              :: numout = 6
+
+!
+!
+!
+
+
+!Config Key  = OCEAN 
+!Config Desc = Type d'ocean
+!Config Def  = force
+!Config Help = Type d'ocean utilise: force, slab,couple
+!
+  ocean = 'force '
+  call getin('OCEAN', ocean)
+!
+!Config Key  = VEGET 
+!Config Desc = Type de modele de vegetation
+!Config Def  = .false.
+!Config Help = Type de modele de vegetation utilise
+!
+  ok_veget = .false.
+  call getin('VEGET', ok_veget)
+!
+!Config Key  = OK_journe
+!Config Desc = Pour des sorties journalieres 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histday contenant les sorties
+!              journalieres 
+!
+  ok_journe = .false.
+  call getin('OK_journe', ok_journe)
+!
+!Config Key  = OK_mensuel
+!Config Desc = Pour des sorties mensuelles 
+!Config Def  = .true.
+!Config Help = Pour creer le fichier histmth contenant les sorties
+!              mensuelles 
+!
+  ok_mensuel = .true.
+  call getin('OK_mensuel', ok_mensuel)
+!
+!Config Key  = OK_instan
+!Config Desc = Pour des sorties instantanees 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histins contenant les sorties
+!              instantanees 
+!
+  ok_instan = .false.
+  call getin('OK_instan', ok_instan)
+
+!
+!
+!
+
+  write(numout,*)' ##############################################'
+  write(numout,*)' Configuration des parametres de la physique: '
+  write(numout,*)' Config ocean = ', ocean
+  write(numout,*)' Config veget = ', ok_veget
+  write(numout,*)' Sortie journaliere = ', ok_journe
+  write(numout,*)' Sortie mensuelle = ', ok_mensuel
+  write(numout,*)' Sortie instantanee = ', ok_instan
+
+
+  return
+
+  end subroutine conf_phys
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/conflx.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/conflx.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/conflx.F	(revision 300)
@@ -65,4 +65,6 @@
       REAL zde_u(klon,klev)
       REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
 cAA
 
@@ -101,6 +103,6 @@
       DO k = 1, klev+1
       DO i = 1, klon
-         pmflxr(i,k) = 0.0
-         pmflxs(i,k) = 0.0
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
       ENDDO
       ENDDO
@@ -150,5 +152,5 @@
      .             rain, snow, kcbot, kctop, kdtop,
      .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
-     .             d_t_bis, d_q_bis, pmflxr, pmflxs)
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
 C
 cAA--------------------------------------------------------
@@ -193,5 +195,11 @@
       ENDDO
 
-c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
       RETURN
       END
@@ -309,5 +317,6 @@
       DO i = 1, klon
          ktype(i) = 2
-         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
       ENDDO
 c
@@ -972,4 +981,6 @@
       ENDDO
 c
+      ldcum(1)=ldcum(1)
+c
       is = 0
       DO i = 1, klon
@@ -1030,10 +1041,12 @@
       REAL plude(klon,klev)
       REAL pdmfup(klon,klev), pdpmel(klon,klev)
-      REAL pdmfdp(klon,klev)
+cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
       REAL prfl(klon), psfl(klon)
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
       INTEGER  kcbot(klon), kctop(klon), ktype(klon)
       LOGICAL  ldland(klon), ldcum(klon)
-      INTEGER k, i
+      INTEGER k, kp, i
       REAL zcons1, zcons2, zcucov, ztmelp2
       REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
@@ -1151,7 +1164,9 @@
          ENDIF
          IF (pten(i,k).GT.RTT) THEN
-           pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
          ELSE
-           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)-pdpmel(i,k)
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
          ENDIF
 c        si la precipitation est negative, on ajuste le plux du
@@ -1167,4 +1182,26 @@
       ENDDO
 c
+cjq The new variable is initialized here.
+cjq It contains the humidity which is fed to the downdraft
+cjq by evaporation of precipitation in the column below the base
+cjq of convection.
+cjq 
+cjq In the former version, this term has been subtracted from precip
+cjq as well as the evaporation.
+cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+cjq End of initialization
+c      
       DO k = ktopm2, klev
       DO i = 1, klon
@@ -1180,4 +1217,11 @@
             zrfln=MAX(zrnew,0.)
             zdrfl=MIN(0.,zrfln-zrfl)
+cjq At least the amount of precipiation needed to feed the downdraft
+cjq with humidity below the base of convection has to be left and can't
+cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,
+     .            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+cjq End of insertion
+c            
             zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
             IF (pten(i,k).GT.RTT) THEN
@@ -1198,5 +1242,7 @@
             pdmfdp(i,k) = 0.0
             pdpmel(i,k) = 0.0
-         ENDIF
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
       ENDIF
       ENDDO
@@ -1539,4 +1585,9 @@
       zalsdcp = rlstt/RCPD
 C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
       DO 210 i =1, klon
       IF (ldflag(i)) THEN
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/conlmd.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/conlmd.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/conlmd.F	(revision 300)
@@ -126,10 +126,8 @@
       INTEGER nb ! nombre de sous-fractions a considere
       PARAMETER (nb=1)
-ccc      PARAMETER (nb=5)
 ccc      PARAMETER (nb=3)
 c
       REAL ratqs ! largeur de la distribution pour vapeur d'eau
-      PARAMETER (ratqs=0.2)
-c
+      PARAMETER (ratqs=0.05)
 c
       REAL w_q(klon,klev)
@@ -167,8 +165,6 @@
       DATA frac / 1.0 /
       DATA opt_cld / 4 /
-ccc      DATA frac    / 1.0, 0.75, 0.50, 0.25, 0.05 /
-ccc      DATA opt_cld / 3,   3,    3,    3,    3 /
 ccc      DATA frac    / 1.0, 0.50, 0.25/
-ccc      DATA opt_cld / 3,   3,    3/
+ccc      DATA opt_cld / 4,   4,    4/
 c
       DATA appel1er /.TRUE./
@@ -248,5 +244,6 @@
          zflo = t(i,k) + zgamdz - t(i,k+1)
          zsat = (q(i,k)-zqs1)*zdp1 + (q(i,k+1)-zqs2)*zdp2
-         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+         IF (zflo.GT.0.0) afaire(i) = .TRUE.
+c erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
       ENDDO
       ENDDO
@@ -339,5 +336,5 @@
       PARAMETER (new_top=.FALSE.)
       LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
-      PARAMETER (evap_prec=.FALSE.)
+      PARAMETER (evap_prec=.TRUE.)
       REAL coef_eva
       PARAMETER (coef_eva=1.0E-05)
@@ -350,9 +347,14 @@
       REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
       REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
-      PARAMETER (dpmin=0.1, tomax=0.2)
+      PARAMETER (dpmin=0.15, tomax=0.97)
       REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
-      PARAMETER (dpmax=0.6, tomin=0.1)
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
       LOGICAL exigent ! implique un calcul supplementaire pour Qs
       PARAMETER (exigent=.FALSE.)
+c
+      INTEGER kbase
+      PARAMETER (kbase=0)
 c
 c Variables locales:
@@ -479,6 +481,6 @@
       DO i = 1, klon
       IF (possible(i)) THEN
-         k1(i) = 0
-         k2(i) = 1
+         k1(i) = kbase
+         k2(i) = k1(i) + 1
       ENDIF
       ENDDO
@@ -688,4 +690,5 @@
      .                 *(tomax-tomin)/(dpmax-dpmin)
       toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,k2(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
       IF (old_tau) toliq(i) = 1.0
       ENDIF
@@ -787,5 +790,6 @@
       ELSE IF (opt_cld.EQ.4) THEN
 c
-         nexpo = 1 ! distribution lineaire
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
 c
          DO i = 1, klon
@@ -927,9 +931,12 @@
       k1max = 1
       DO i = 1, klon
-      IF (todo(i) .AND. k1(i).GT.1) THEN
+      IF (todo(i) .AND. k1(i).GT.(kbase+1)) THEN
          k = k1(i)
          zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
          zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
-         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+csc voici l'ancienne ligne:
+csc         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+csc sylvain: il faut RESPECTER les 2 criteres:
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
             etendre(i) = .TRUE.
             k1(i) = k1(i) - 1
@@ -940,6 +947,6 @@
       ENDDO
 c
-      IF (k1max.GT.1) THEN
-      DO k = k1max, 1, -1
+      IF (k1max.GT.(kbase+1)) THEN
+      DO k = k1max, kbase+1, -1
       DO i = 1, klon
       IF (etendre(i) .AND. k.LT.k1(i) .AND. aller(i)) THEN
@@ -1095,5 +1102,5 @@
       PARAMETER (opt_cld=4) ! valeur possible: 0, 1, 2, 3 ou 4
       LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
-      PARAMETER (evap_prec=.FALSE.)
+      PARAMETER (evap_prec=.TRUE.)
       REAL coef_eva
       PARAMETER (coef_eva=1.0E-05)
@@ -1106,7 +1113,9 @@
       REAL toliq(klon) ! rapport entre l'eau nuageuse et l'eau precipitante
       REAL dpmin, tomax !Epaisseur faible, rapport eau liquide plus grande
-      PARAMETER (dpmin=0.1, tomax=0.2)
+      PARAMETER (dpmin=0.15, tomax=0.97)
       REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
-      PARAMETER (dpmax=0.6, tomin=0.1)
+      PARAMETER (dpmax=0.30, tomin=0.05)
+      REAL deep_sig, deep_to ! au dela de deep_sig, utiliser deep_to
+      PARAMETER (deep_sig=0.50, deep_to=0.05)
 c
 c Variables locales:
@@ -1383,4 +1392,5 @@
      .             *(tomax-tomin)/(dpmax-dpmin)
       toliq(i) = MAX(tomin,MIN(tomax,toliq(i)))
+      IF (pplay(i,kh(i))/paprs(i,1) .LE. deep_sig) toliq(i) = deep_to
       IF (old_tau) toliq(i) = 1.0
       ENDIF
@@ -1497,5 +1507,6 @@
       ELSE IF (opt_cld.EQ.4) THEN
 c
-         nexpo = 1 ! distribution lineaire
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
 c
          DO i = 1, klon
@@ -1708,4 +1719,8 @@
 #include "YOETHF.h"
 #include "FCTTRE.h"
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
 C
       DO 210 i=1, klon
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect1.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect1.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect1.F	(revision 300)
@@ -0,0 +1,645 @@
+      subroutine convect1(len,nd,ndp1,noff,minorig,
+     &                   t,q,qs,u,v,
+     &                   p,ph,iflag,ft,
+     &                   fq,fu,fv,precip,cbmf,delt,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect1.f	1.1 04/21/00
+C                       19:40:52 /h/cm/library/nogaps4/src/sub/fcst/convect1.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect1
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect1(len,nd,noff,minorig,
+C    &                   t,q,qs,u,v,
+C    &                   p,ph,iflag,ft,
+C    &                   fq,fu,fv,precip,cbmf,delt)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      noff          Integer        Input        integer limit for convection (nd-noff)
+C      minorig       Integer        Input        First level of convection
+C      t             Real           Input        temperature
+C      q             Real           Input        specific hum
+C      qs            Real           Input        sat specific hum
+C      u             Real           Input        u-wind
+C      v             Real           Input        v-wind
+C      p             Real           Input        full level pressure
+C      ph            Real           Input        half level pressure
+C      iflag         Integer        Output       iflag on latitude strip
+C      ft            Real           Output       temp tend
+C      fq            Real           Output       spec hum tend
+C      fu            Real           Output       u-wind tend
+C      fv            Real           Output       v-wind tend
+C      cbmf          Real           In/Out       cumulus mass flux
+C      delt          Real           Input        time step
+C      iflag         Integer        Output       integer flag for Emanuel conditions
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         convect2        Emanuel cumulus convection tendency calculations
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphy.h"
+c
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      real t(len,nd)
+      real q(len,nd)
+      real qs(len,nd)
+      real u(len,nd)
+      real v(len,nd)
+      real p(len,nd)
+      real ph(len,ndp1)
+      integer iflag(len)
+      real ft(len,nd)
+      real fq(len,nd)
+      real fu(len,nd)
+      real fv(len,nd)
+      real precip(len)
+      real cbmf(len)
+      real Ma(len,nd)
+      integer minorig
+      real delt,cpd,cpv,cl,rv,rd,lv0,g
+      real sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp
+      real alpha,entp,coeffs,coeffr,omtrain,cu
+c
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+      integer nl
+      integer nlp
+      integer nlm
+      integer i,k,n
+      real delti
+      real rowl
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real ginv
+      real hrd
+      real prccon1
+      integer icbmax
+      real lv(klon,klev)
+      real cpn(klon,klev)
+      real cpx(klon,klev)
+      real tv(klon,klev)
+      real gz(klon,klev)
+      real hm(klon,klev)
+      real h(klon,klev)
+      real work(klon)
+      integer ihmin(klon)
+      integer nk(klon)
+      real rh(klon)
+      real chi(klon)
+      real plcl(klon)
+      integer icb(klon)
+      real tnk(klon)
+      real qnk(klon)
+      real gznk(klon)
+      real pnk(klon)
+      real qsnk(klon)
+      real ticb(klon)
+      real gzicb(klon)
+      real tp(klon,klev)
+      real tvp(klon,klev)
+      real clw(klon,klev)
+c
+      real ah0(klon),cpp(klon)
+      real tg,qg,s,alv,tc,ahg,denom,es,rg
+c
+      integer ncum
+      integer idcum(klon)
+c
+      cpd=1005.7
+      cpv=1870.0
+      cl=4190.0
+      rv=461.5
+      rd=287.04
+      lv0=2.501E6
+      g=9.8
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+      sigs=0.12
+      sigd=0.05
+      elcrit=0.0011
+      tlcrit=-55.0
+      omtsnow=5.5
+      dtmax=0.9
+      damp=0.1
+      alpha=0.2
+      entp=1.5
+      coeffs=0.8
+      coeffr=1.0
+      omtrain=50.0
+c
+      cu=0.70
+      damp=0.1
+c
+c
+c Define nl, nlp, nlm, and delti
+c
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+      delti=1.0/delt
+!
+!-------------------------------------------------------------------
+! --- SET CONSTANTS
+!-------------------------------------------------------------------
+!
+      rowl=1000.0
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+      ginv=1.0/g
+      hrd=0.5*rd
+      prccon1=86400.0*1000.0/(rowl*g)
+!
+! dtmax is the maximum negative temperature perturbation.
+!
+!=====================================================================
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!=====================================================================
+!
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft(i,k)=0.0
+         fq(i,k)=0.0
+         fu(i,k)=0.0
+         fv(i,k)=0.0
+         tvp(i,k)=0.0
+         tp(i,k)=0.0
+         clw(i,k)=0.0
+         gz(i,k) = 0.
+ 10     continue
+ 20   continue
+      do 60 i=1,len
+        precip(i)=0.0
+        iflag(i)=0
+ 60   continue
+c
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+      do 110 k=1,nl+1
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+c
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+!
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+!
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-273.15
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+c
+      ncum=0
+      do 400 i=1,len
+        if(iflag(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+c Call convect2, which compresses the points and computes the heating,
+c moistening, velocity mixing, and precipiation.
+c
+c     print*,'cpd avant convect2 ',cpd
+      if(ncum.gt.0)then
+      call convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &              nk,icb,
+     &              t,q,qs,u,v,gz,tv,tp,tvp,clw,h,
+     &              lv,cpn,p,ph,ft,fq,fu,fv,
+     &              tnk,qnk,gznk,plcl,
+     &              precip,cbmf,iflag,
+     &              delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &              sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &              alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+      endif
+c
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect2.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect2.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect2.F	(revision 300)
@@ -0,0 +1,1391 @@
+      subroutine convect2(ncum,idcum,len,nd,ndp1,nl,minorig,
+     &                 nk1,icb1,
+     &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+     &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+     &                 tnk1,qnk1,gznk1,plcl1,
+     &                 precip1,cbmf1,iflag1,
+     &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+     &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+     &                 alpha,entp,coeffs,coeffr,omtrain,cu,Ma)
+C.............................START PROLOGUE............................
+C
+C SCCS IDENTIFICATION:  @(#)convect2.f	1.2 05/18/00
+C                       22:06:22 /h/cm/library/nogaps4/src/sub/fcst/convect2.f_v
+C
+C CONFIGURATION IDENTIFICATION:  None
+C
+C MODULE NAME:  convect2
+C
+C DESCRIPTION:
+C
+C convect1     The Emanuel Cumulus Convection Scheme - compute tendencies
+C
+C CONTRACT NUMBER AND TITLE:  None
+C
+C REFERENCES: Programmers  K. Emanuel (MIT), Timothy F. Hogan, M. Peng (NRL)
+C
+C CLASSIFICATION:  Unclassified
+C
+C RESTRICTIONS: None
+C
+C COMPILER DEPENDENCIES: FORTRAN 77, FORTRAN 90
+C
+C COMPILE OPTIONS: Fortran 77: -Zu -Wf"-ei -o aggress"
+C                  Fortran 90: -O vector3,scalar3,task1,aggress,overindex  -ei -r 2
+C
+C LIBRARIES OF RESIDENCE: /a/ops/lib/libfcst159.a
+C
+C USAGE: call convect2(ncum,idcum,len,nd,nl,minorig,
+C    &                 nk1,icb1,
+C    &                 t1,q1,qs1,u1,v1,gz1,tv1,tp1,tvp1,clw1,h1,
+C    &                 lv1,cpn1,p1,ph1,ft1,fq1,fu1,fv1,
+C    &                 tnk1,qnk1,gznk1,plcl1,
+C    &                 precip1,cbmf1,iflag1,
+C    &                 delt,cpd,cpv,cl,rv,rd,lv0,g,
+C    &                 sigs,sigd,elcrit,tlcrit,omtsnow,dtmax,damp,
+C    &                 alpha,entp,coeffs,coeffr,omtrain,cu)
+C
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      ncum          Integer        Input        number of cumulus points
+C      idcum         Integer        Input        index of cumulus point
+C      len           Integer        Input        first dimension
+C      nd            Integer        Input        total vertical dimension
+C      ndp1          Integer        Input        nd + 1
+C      nl            Integer        Input        vertical dimension for convection
+C      minorig       Integer        Input        First level where convection is allow to begin
+C      nk1           Integer        Input        First level of convection
+C      ncb1          Integer        Input        Level of free convection
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      gz1           Real           Inout        geop
+C      tv1           Real           Input        virtual temp
+C      tp1           Real           Input
+C      clw1          Real           Inout        cloud liquid water
+C      h1            Real           Inout
+C      lv1           Real           Inout
+C      cpn1          Real           Inout
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      precip1       Real           Output       prec
+C      cbmf1         Real           In/Out       cumulus mass flux
+C      iflag1        Integer        Output       iflag on latitude strip
+C      delt          Real           Input        time step
+C      cpd           Integer        Input        See description below
+C      cpv           Integer        Input        See description below
+C      cl            Integer        Input        See description below
+C      rv            Integer        Input        See description below
+C      rd            Integer        Input        See description below
+C      lv0           Integer        Input        See description below
+C      g             Integer        Input        See description below
+C      sigs          Integer        Input        See description below
+C      sigd          Integer        Input        See description below
+C      elcrit        Integer        Input        See description below
+C      tlcrit        Integer        Input        See description below
+C      omtsnow       Integer        Input        See description below
+C      dtmax         Integer        Input        See description below
+C      damp          Integer        Input        See description below
+C      alpha         Integer        Input        See description below
+C      ent           Integer        Input        See description below
+C      coeffs        Integer        Input        See description below
+C      coeffr        Integer        Input        See description below
+C      omtrain       Integer        Input        See description below
+C      cu            Integer        Input        See description below
+C
+C COMMON BLOCKS:
+C      Block      Name     Type    Usage              Notes
+C     --------  --------   ----    ------   ------------------------
+C
+C FILES: None
+C
+C DATA BASES: None
+C
+C NON-FILE INPUT/OUTPUT: None
+C
+C ERROR CONDITIONS: None
+C
+C ADDITIONAL COMMENTS: None
+C
+C.................MAINTENANCE SECTION................................
+C
+C MODULES CALLED:
+C         Name           Description
+C         zilch        Zero out an array
+C        -------     ----------------------
+C LOCAL VARIABLES AND
+C          STRUCTURES:
+C Name     Type    Description
+C -------  ------  -----------
+C See Comments Below
+C
+C i        Integer loop index
+C k        Integer loop index
+c
+C METHOD:
+C
+C See Emanuel, K. and M. Zivkovic-Rothman, 2000: Development and evaluation of a
+C       convective scheme for use in climate models.
+C
+C FILES: None
+C
+C INCLUDE FILES: None
+C
+C MAKEFILE: /a/ops/met/nogaps/src/sub/fcst/fcst159lib.mak
+C
+C..............................END PROLOGUE.............................
+c
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphy.h"
+c
+      integer kmax2,imax2,kmin2,imin2
+      real ftmax2,ftmin2
+      integer kmax,imax,kmin,imin
+      real ftmax,ftmin
+c
+      integer ncum
+      integer idcum(len)
+      integer len
+      integer nd
+      integer ndp1
+      integer nl
+      integer minorig
+      integer nk1(len)
+      integer icb1(len)
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real gz1(len,nd)
+      real tv1(len,nd)
+      real tp1(len,nd)
+      real tvp1(len,nd)
+      real clw1(len,nd)
+      real h1(len,nd)
+      real lv1(len,nd)
+      real cpn1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real tnk1(len)
+      real qnk1(len)
+      real gznk1(len)
+      real precip1(len)
+      real cbmf1(len)
+      real plcl1(len)
+      integer iflag1(len)
+      real delt
+      real cpd
+      real cpv
+      real cl
+      real rv
+      real rd
+      real lv0
+      real g
+      real sigs    ! SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE
+      real sigd    ! SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT
+      real elcrit  ! ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm)
+      real tlcrit  ! TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-
+c                     CONVERSION THRESHOLD IS ASSUMED TO BE ZERO
+      real omtsnow ! OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW
+      real dtmax   ! DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION
+c                    A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC.
+      real damp
+      real alpha
+      real entp    ! ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT FORMULATION
+      real coeffs  ! COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF SNOW
+      real coeffr  ! COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION OF RAIN
+      real omtrain ! OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN
+      real cu      ! CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM TRANSPORT
+c
+      real Ma(len,nd)
+c
+C
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+c
+c Local arrays.
+c
+      real work(ncum)
+      real t(ncum,klev)
+      real q(ncum,klev)
+      real qs(ncum,klev)
+      real u(ncum,klev)
+      real v(ncum,klev)
+      real gz(ncum,klev)
+      real h(ncum,klev)
+      real lv(ncum,klev)
+      real cpn(ncum,klev)
+      real p(ncum,klev)
+      real ph(ncum,klev)
+      real ft(ncum,klev)
+      real fq(ncum,klev)
+      real fu(ncum,klev)
+      real fv(ncum,klev)
+      real precip(ncum)
+      real cbmf(ncum)
+      real plcl(ncum)
+      real tnk(ncum)
+      real qnk(ncum)
+      real gznk(ncum)
+      real tv(ncum,klev)
+      real tp(ncum,klev)
+      real tvp(ncum,klev)
+      real clw(ncum,klev)
+c     real det(ncum,klev)
+      real dph(ncum,klev)
+c     real wd(ncum)
+c     real tprime(ncum)
+c     real qprime(ncum)
+      real ah0(ncum)
+      real ep(ncum,klev)
+      real sigp(ncum,klev)
+      integer nent(ncum,klev)
+      real water(ncum,klev)
+      real evap(ncum,klev)
+      real mp(ncum,klev)
+      real m(ncum,klev)
+      real qti
+      real wt(ncum,klev)
+      real hp(ncum,klev)
+      real lvcp(ncum,klev)
+      real elij(ncum,klev,klev)
+      real ment(ncum,klev,klev)
+      real sij(ncum,klev,klev)
+      real qent(ncum,klev,klev)
+      real uent(ncum,klev,klev)
+      real vent(ncum,klev,klev)
+      real qp(ncum,klev)
+      real up(ncum,klev)
+      real vp(ncum,klev)
+      real cape(ncum)
+      real capem(ncum)
+      real frac(ncum)
+      real dtpbl(ncum)
+      real tvpplcl(ncum)
+      real tvaplcl(ncum)
+      real dtmin(ncum)
+      real w3d(ncum,klev)
+      real am(ncum)
+      real ents(ncum)
+      real uav(ncum)
+      real vav(ncum)
+c
+      integer iflag(ncum)
+      integer nk(ncum)
+      integer icb(ncum)
+      integer inb(ncum)
+      integer inb1(ncum)
+      integer jtt(ncum)
+c
+      integer nn,i,k,n,icbmax,nlp,j
+      integer ij
+      integer nn2,nn3
+      real clmcpv
+      real clmcpd
+      real cpdmcp
+      real cpvmcpd
+      real eps
+      real epsi
+      real epsim1
+      real tg,qg,s,alv,tc,ahg,denom,es,rg,ginv,rowl
+      real delti
+      real tca,elacrit
+      real by,defrac
+c     real byp
+      real byp(ncum)
+      logical lcape(ncum)
+      real dbo
+      real bf2,anum,dei,altem,cwat,stemp
+      real alt,qp1,smid,sjmax,sjmin
+      real delp,delm
+      real awat,coeff,afac,revap,dhdp,fac,qstm,rat
+      real qsm,sigt,b6,c6
+      real dpinv,cpinv
+      real fqold,ftold,fuold,fvold
+      real wdtrain(ncum),xxx
+      real bsum(ncum,klev)
+      real asij(ncum)
+      real smin(ncum)
+      real scrit(ncum)
+c     real amp1,ad
+      real amp1(ncum),ad(ncum)
+      logical lwork(ncum)
+      integer num1,num2
+c
+c     print*,'cpd en entree de convect2 ',cpd
+      nlp=nl+1
+c
+      rowl=1000.0
+      ginv=1.0/g
+      delti=1.0/delt
+c
+c Define some thermodynamic variables.
+c
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      eps=rd/rv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c
+c Compress the fields.
+c
+      do 110 k=1,nl+1
+       nn=0
+	do 100 i=1,len
+	  if(iflag1(i).eq.0)then
+	    nn=nn+1
+	    t(nn,k)=t1(i,k)
+	    q(nn,k)=q1(i,k)
+	    qs(nn,k)=qs1(i,k)
+	    u(nn,k)=u1(i,k)
+	    v(nn,k)=v1(i,k)
+	    gz(nn,k)=gz1(i,k)
+	    h(nn,k)=h1(i,k)
+	    lv(nn,k)=lv1(i,k)
+	    cpn(nn,k)=cpn1(i,k)
+	    p(nn,k)=p1(i,k)
+	    ph(nn,k)=ph1(i,k)
+	    tv(nn,k)=tv1(i,k)
+	    tp(nn,k)=tp1(i,k)
+	    tvp(nn,k)=tvp1(i,k)
+	    clw(nn,k)=clw1(i,k)
+	  endif
+ 100    continue
+c       print*,'100 ncum,nn',ncum,nn
+ 110  continue
+      nn=0
+      do 150 i=1,len
+	if(iflag1(i).eq.0)then
+	  nn=nn+1
+	  cbmf(nn)=cbmf1(i)
+	  plcl(nn)=plcl1(i)
+	  tnk(nn)=tnk1(i)
+	  qnk(nn)=qnk1(i)
+	  gznk(nn)=gznk1(i)
+	  nk(nn)=nk1(i)
+	  icb(nn)=icb1(i)
+	  iflag(nn)=iflag1(i)
+	endif
+ 150  continue
+c       print*,'150 ncum,nn',ncum,nn
+c
+c Initialize the tendencies, det, wd, tprime, qprime.
+c
+      do 170 k=1,nl
+	do 160 i=1,ncum
+c         det(i,k)=0.0
+	  ft(i,k)=0.0
+	  fu(i,k)=0.0
+	  fv(i,k)=0.0
+	  fq(i,k)=0.0
+	  dph(i,k)=ph(i,k)-ph(i,k+1)
+	  ep(i,k)=0.0
+	  sigp(i,k)=sigs
+ 160    continue
+ 170  continue
+      do 180 i=1,ncum
+c      wd(i)=0.0
+c      tprime(i)=0.0
+c      qprime(i)=0.0
+       precip(i)=0.0
+       ft(i,nl+1)=0.0
+       fu(i,nl+1)=0.0
+       fv(i,nl+1)=0.0
+       fq(i,nl+1)=0.0
+ 180  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 230 i=1,ncum
+	icbmax=max(icbmax,icb(i))
+ 230  continue
+c
+c
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+	ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-273.15
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+		es=6.112*exp(17.67*tc/denom)
+	       else
+		es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+		qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+	       tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)
+     &                  /cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-273.15
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c
+c=====================================================================
+c --- NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          water(i,1)=0.0
+          evap(i,1)=0.0
+          mp(i,1)=0.0
+          m(i,1)=0.0
+          wt(i,1)=omtsnow
+          hp(i,1)=h(i,1)
+c         if(.not.cpn(i,1).gt.900.) then
+c         print*,'i,lv(i,1),cpn(i,1)'
+c         print*, i,lv(i,1),cpn(i,1)
+c         k=(i-1)/ncum+1
+c         print*,'i,k',mod(i,ncum),k,'  cpn',cpn(mod(i,ncum),k)
+c         stop
+c         endif
+          lvcp(i,1)=lv(i,1)/cpn(i,1)
+ 360    continue
+c
+      do 380 i=1,ncum*nlp*nlp
+        elij(i,1,1)=0.0
+        ment(i,1,1)=0.0
+        sij(i,1,1)=0.0
+ 380  continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+ 385      continue
+ 390    continue
+ 400  continue
+c
+      do 420 i=1,ncum
+        qp(i,1)=q(i,1)
+        up(i,1)=u(i,1)
+        vp(i,1)=v(i,1)
+ 420  continue
+      do 440 k=2,nlp
+        do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430    continue
+ 440  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I),
+c --- AT EACH MODEL LEVEL
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+c
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+c     wd=beta*abs(mp(icb))*0.01*rd*t(icb)/(sigd*p(icb))
+c     qprime=0.5*(qp(1)-q(1))
+c     tprime=lv0*qprime/cpd
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+           endif
+ 1910    continue
+ 1920   continue
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+ 2010     continue
+ 2020   continue
+c
+      DO k=1,nd
+        DO i=1,len
+         Ma(i,k) = 0.
+        ENDDO
+      ENDDO
+      DO k=nl,1,-1
+        DO i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        ENDDO
+      ENDDO
+c
+        return
+        end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect3.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect3.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/convect3.F	(revision 300)
@@ -0,0 +1,1252 @@
+c $Header$
+      SUBROUTINE CONVECT
+     *    (DTIME,  T1,   R1,   RS,    U,  V,  TRA,   P,     PH,
+     *     ND,       NDP1,     NL, NTRA,  DELT,  IFLAG,
+     *     FT, FR, FU,  FV,  FTRA,  PRECIP,
+     *     icb,inb,   upwd,dnwd,dnwd0,SIG, W0,Mike,Mke,
+     *     Ma,MENTS,QENTS,TPS,TLS,SIGIJ,CAPE,TVP,PBASE,BUOYBASE,
+     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+C
+C    ***  THE PARAMETER NA SHOULD IN GENERAL EQUAL ND   ***
+C
+c#################################################################
+cFleur       Introduction des traceurs dans convect3 le 6 juin 200
+c#################################################################
+#include "dimensions.h"
+#include "dimphy.h"
+      PARAMETER (NA=60)
+
+      integer NTRAC
+      PARAMETER (NTRAC=nqmx-2)
+
+      INTEGER NENT(NA)
+      REAL T1(ND),R1(ND),RS(ND),U(ND),V(ND),TRA(ND,NTRA)
+      REAL P(ND),PH(NDP1)
+      REAL FT(ND),FR(ND),FU(ND),FV(ND),FTRA(ND,NTRA)
+      REAL SIG(ND),W0(ND)
+      REAL UENT(NA,NA),VENT(NA,NA),TRAENT(NA,NA,NTRAC),TRATM(NA)
+      REAL UP(NA),VP(NA),TRAP(NA,NTRAC)
+      REAL M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
+      REAL SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
+      REAL RP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
+      REAL SIGP(NA),B(NA),TP(NA),CPN(NA)
+      REAL LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA)
+      REAL T(NA),RR(NA)
+C
+      REAL BUOY(NA)     !  Lifted parcel buoyancy
+      REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                      temperature wrt T1 and Q1
+      REAL CLW_NEW(NA),QI(NA)
+C
+      LOGICAL ICE_CONV
+      PARAMETER (ICE_CONV=.TRUE.)
+ 
+cccccccccccccccccccccccccccccccccccccccccccccc
+c     declaration des variables a sortir
+ccccccccccccccccccccccccccccccccccccccccccccc
+      real Mke(nd)
+      real Mike(nd)
+      real Ma(nd)
+      real TPS(ND) !temperature dans les ascendances non diluees
+      real TLS(ND) !temperature potentielle
+      real MENTS(nd,nd)
+      real QENTS(nd,nd)
+      REAL SIGIJ(KLEV,KLEV)
+      REAL PBASE ! pressure at the cloud base level
+      REAL BUOYBASE ! buoyancy at the cloud base level
+cccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+ 
+c
+      real dnwd0(nd)  !  precipitation driven unsaturated downdraft flux
+      real dnwd(nd), dn1  ! in-cloud saturated downdraft mass flux
+      real upwd(nd), up1  ! in-cloud saturated updraft mass flux
+C
+C   ***         ASSIGN VALUES OF THERMODYNAMIC CONSTANTS        ***
+C   ***             THESE SHOULD BE CONSISTENT WITH             ***
+C   ***              THOSE USED IN CALLING PROGRAM              ***
+C   ***     NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT  ***
+C
+c sb      CPD=1005.7
+c sb      CPV=1870.0
+c sb      CL=4190.0
+c sb      CPVMCL=CL-CPV
+c sb      RV=461.5
+c sb      RD=287.04
+c sb      EPS=RD/RV
+c sb      ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CPVMCL=CL-CPV
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+cccccccccccccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CPVMCL = CL-CPV
+       EPS = RD/RV
+       ALV0 = RLVTT
+c
+       NK = 1 ! origin level of the lifted parcel
+c
+cccccccccccccccccccccc
+C
+C           ***  INITIALIZE OUTPUT ARRAYS AND PARAMETERS  ***
+C
+      DO 5 I=1,ND
+         FT(I)=0.0
+         FR(I)=0.0
+         FU(I)=0.0
+         FV(I)=0.0
+         DO 4 J=1,NTRA
+          FTRA(I,J)=0.0
+    4    CONTINUE
+         T(I)=T1(I)
+         RR(I)=R1(I)
+    5 CONTINUE
+      DO 7 I=1,NL
+         RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+         TH(I)=T(I)*(1000.0/P(I))**RDCP
+    7 CONTINUE
+C
+*************************************************************
+**    CALCUL DES TEMPERATURES POTENTIELLES A SORTIR
+*************************************************************
+      do i=1,ND
+      RDCP=(RD*(1.-RR(I))+RR(I)*RV)/ (CPD*(1.-RR(I))+RR(I)*CPV)
+ 
+      TLS(i)=T(I)*(1000.0/P(I))**RDCP
+      enddo
+ 
+ 
+ 
+ 
+************************************************************
+ 
+ 
+      PRECIP=0.0
+      IFLAG=1
+C
+C   ***                    SPECIFY PARAMETERS                        ***
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE   ***
+C   ***       PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO         ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP.      ***
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY                 ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE      ***
+C   ***                        OF CLOUD                              ***
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY)    ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)             ***
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***                     IT MUST BE LESS THAN 0                   ***
+C
+      PBCRIT=150.0
+      PTCRIT=500.0
+      SIGD=0.01
+      SPFAC=0.15
+c sb:
+      EPMAX=0.993 ! precip efficiency less than unity
+c      EPMAX=1. ! precip efficiency less than unity
+C
+Cjyg
+CCC      BETA=0.96
+C  Beta is now expressed as a function of the characteristic time
+C  of the convective process.
+CCC        Old value : TAU = 15000.   !(for dtime = 600.s)
+CCC        Other value (inducing little change) :TAU = 8000.
+      TAU = 8000.
+      BETA = 1.-DTIME/TAU
+Cjyg
+CCC      ALPHA=1.0
+      ALPHA=1.5E-3*DTIME/TAU
+C        Increase alpha in order to compensate W decrease
+      ALPHA = ALPHA*1.5
+C
+Cjyg (voir CONVECT 3)
+CCC      DTCRIT=-0.2
+      DTCRIT=-2.
+Cgf&jyg
+CCC     DT pour l'overshoot.
+      DTOVSH = -0.2
+ 
+C
+C           ***        INCREMENT THE COUNTER       ***
+C
+      SIG(ND)=SIG(ND)+1.0
+      SIG(ND)=AMIN1(SIG(ND),12.1)
+C
+C           ***    IF NOPT IS AN INTEGER OTHER THAN 0, CONVECT     ***
+C           ***     RETURNS ARRAYS T AND R THAT MAY HAVE BEEN      ***
+C           ***  ALTERED BY DRY ADIABATIC ADJUSTMENT; OTHERWISE    ***
+C           ***        THE RETURNED ARRAYS ARE UNALTERED.          ***
+C
+      NOPT=0
+C
+C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+C
+C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+C     ***                BOUNDARY LAYER SCHEME !!!               ***
+C
+c test sb      DO 30 I=NL-1,1,-1
+c test sb         JN=0
+c test sb         DO 10 J=I+1,NL
+c test sb   10    IF(TH(J).LT.TH(I))JN=J
+c test sb         IF(JN.EQ.0)GOTO 30
+c test sb         AHM=0.0
+c test sb         RM=0.0
+c test sb         UM=0.0
+c test sb         VM=0.0
+c test sb         DO K=1,NTRA
+c test sb          TRATM(K)=0.0
+c test sb         END DO
+c test sb         DO 15 J=I,JN
+c test sb          AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1))
+c test sb          RM=RM+RR(J)*(PH(J)-PH(J+1))
+c test sb          UM=UM+U(J)*(PH(J)-PH(J+1))
+c test sb          VM=VM+V(J)*(PH(J)-PH(J+1))
+c test sb          DO K=1,NTRA
+c test sb           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
+c test sb          END DO
+c test sb   15    CONTINUE
+c test sb         DPHINV=1./(PH(I)-PH(JN+1))
+c test sb         RM=RM*DPHINV
+c test sb         UM=UM*DPHINV
+c test sb         VM=VM*DPHINV
+c test sb         DO K=1,NTRA
+c test sb          TRATM(K)=TRATM(K)*DPHINV
+c test sb         END DO
+c test sb         A2=0.0
+c test sb         DO 20 J=I,JN
+c test sb            RR(J)=RM
+c test sb          U(J)=UM
+c test sb          V(J)=VM
+c test sb          DO K=1,NTRA
+c test sb           TRA(J,K)=TRATM(K)
+c test sb          END DO
+c test sb            RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV)
+c test sb            X=(0.001*P(J))**RDCP
+c test sb            T(J)=X
+c test sb            A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1))
+c test sb   20    CONTINUE
+c test sb         DO 25 J=I,JN
+c test sb            TH(J)=AHM/A2
+c test sb            T(J)=T(J)*TH(J)
+c test sb   25    CONTINUE
+c test sb   30 CONTINUE
+C
+C   ***   RESET INPUT ARRAYS IF NOPT .NE. 0   ***
+C
+      IF (NOPT.NE.0)THEN
+         DO 35 I=1,ND
+            T1(I)=T(I)
+            R1(I)=RR(I)
+   35    CONTINUE
+      END IF
+C
+C  *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
+C
+      GZ(1)=0.0
+      CPN(1)=CPD*(1.-RR(1))+RR(1)*CPV
+      H(1)=T(1)*CPN(1)
+      DO 40 I=2,NL
+        TVX=T(I)*(1.+RR(I)/EPS-RR(I))
+        TVY=T(I-1)*(1.+RR(I-1)/EPS-RR(I-1))
+        GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(P(I-1)-P(I))/PH(I)
+        CPN(I)=CPD*(1.-RR(I))+CPV*RR(I)
+        H(I)=T(I)*CPN(I)+GZ(I)
+   40 CONTINUE
+C
+C   ***  CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT LOWEST MODEL LEVEL ***
+C   ***       (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980)     ***
+C
+      IF (T(1).LT.250.0.OR.RR(1).LE.0.0)THEN
+         IFLAG=0
+c sb3d         print*,'je suis passe par 366'
+         RETURN
+      END IF
+
+cjyg1 Utilisation de la subroutine CLIFT
+CC      RH=RR(1)/RS(1)
+CC      CHI=T(1)/(1669.0-122.0*RH-T(1))
+CC      PLCL=P(1)*(RH**CHI)
+      CALL CLIFT(P(1),T(1),RR(1),RS(1),PLCL,DPLCLDT,DPLCLDR)
+cjyg2
+c sb3d      PRINT *,' em_plcl,p1,t1,r1,rs1,rh '
+c sb3d     $        ,PLCL,P(1),T(1),RR(1),RS(1),RH
+c
+      IF (PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
+         IFLAG=2
+         RETURN
+      END IF
+Cjyg1
+C     Essais de modification de ICB
+C
+C   ***  CALCULATE FIRST LEVEL ABOVE LCL (=ICB)  ***
+C
+CC      ICB=NL-1
+CC      DO 50 I=2,NL-1
+CC         IF(P(I).LT.PLCL)THEN
+CC            ICB=MIN(ICB,I)   ! ICB sup ou egal a 2
+CC         END IF
+CC   50 CONTINUE
+CC      IF(ICB.EQ.(NL-1))THEN
+CC         IFLAG=3
+CC         RETURN
+CC      END IF
+C
+C   *** CALCULATE LAYER CONTAINING LCL (=ICB)   ***
+C
+      ICB=NL-1
+c sb      DO 50 I=2,NL-1
+      DO 50 I=3,NL-1 ! modif sb pour que ICB soit sup/egal a 2
+C   la modification consiste a comparer PLCL a PH et non a P:
+C   ICB est defini par :  PH(ICB)<PLCL<PH(ICB-!)
+         IF(PH(I).LT.PLCL)THEN
+            ICB=MIN(ICB,I)
+         END IF
+   50 CONTINUE
+      IF(ICB.EQ.(NL-1))THEN
+         IFLAG=3
+         RETURN
+      END IF
+      ICB = ICB-1 ! ICB sup ou egal a 2 
+Cjyg2
+C
+C
+ 
+C   *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL      ***
+C   ***  TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC             ***
+C   ***                   LIQUID WATER CONTENT                             ***
+C
+ 
+cjyg1
+c make sure that "Cloud base" seen by TLIFT is actually the 
+c fisrt level where adiabatic ascent is saturated 
+       IF (PLCL .GT. P(ICB)) THEN
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ELSE
+c sb        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,TVP,TP,CLW,ND,NL)
+        CALL TLIFT(P,T,RR,RS,GZ,PLCL,ICB+1,NK,TVP,TP,CLW,ND,NL
+     :            ,DTVPDT1,DTVPDQ1)
+       ENDIF
+cjyg2
+ 
+******************************************************************************
+****     SORTIE DE LA TEMPERATURE DE L ASCENDANCE NON DILUE
+******************************************************************************
+        do i=1,ND
+        TPS(i)=TP(i)
+        enddo
+ 
+ 
+******************************************************************************
+ 
+C
+C   ***  SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF   ***
+C   ***          PRECIPITATION FALLING OUTSIDE OF CLOUD           ***
+C   ***      THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)     ***
+C
+      DO 55 I=1,NL
+         PDEN=PTCRIT-PBCRIT
+c
+cjyg
+ccc         EP(I)=(P(ICB)-P(I)-PBCRIT)/PDEN
+c sb         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN
+         EP(I)=(PLCL-P(I)-PBCRIT)/PDEN * EPMAX ! sb
+c
+         EP(I)=AMAX1(EP(I),0.0)
+c sb         EP(I)=AMIN1(EP(I),1.0)
+         EP(I)=AMIN1(EP(I),EPMAX) ! sb
+         SIGP(I)=SPFAC
+C
+C   ***       CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL     ***
+C   ***                    VIRTUAL TEMPERATURE                    ***
+C
+         TV(I)=T(I)*(1.+RR(I)/EPS-RR(I))
+Ccd1
+C    . Keep all liquid water in lifted parcel (-> adiabatic CAPE)
+C
+ccc    TVP(I)=TVP(I)-TP(I)*(RR(1)-EP(I)*CLW(I))
+c!!! sb         TVP(I)=TVP(I)-TP(I)*RR(1) ! calcule dans tlift
+Ccd2
+C
+C   ***       Calculate first estimate of buoyancy
+C
+         BUOY(I) = TVP(I) - TV(I)
+   55 CONTINUE
+C
+C   ***   Set Cloud Base Buoyancy at (Plcl+DPbase) level buoyancy
+C
+      DPBASE = -40.   !That is 400m above LCL
+      PBASE = PLCL + DPBASE
+      TVPBASE = TVP(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $         +TVP(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+      TVBASE = TV(ICB  )*(PBASE -P(ICB+1))/(P(ICB)-P(ICB+1))
+     $        +TV(ICB+1)*(P(ICB)-PBASE   )/(P(ICB)-P(ICB+1))
+C
+      BUOYBASE = TVPBASE - TVBASE
+C
+CC       Set buoyancy = BUOYBASE for all levels below BASE.
+CC       For safety, set : BUOY(ICB) = BUOYBASE
+      DO I = ICB,NL
+        IF (P(I) .GE. PBASE) THEN
+          BUOY(I) = BUOYBASE
+        ENDIF
+      ENDDO
+      BUOY(ICB) = BUOYBASE
+C
+c sb3d      print *,'buoybase,tvp_tv,tvpbase,tvbase,pbase,plcl'
+c sb3d     $,        buoybase,tvp(icb)-tv(icb),tvpbase,tvbase,pbase,plcl
+c sb3d      print *,'TVP ',(tvp(i),i=1,nl)
+c sb3d      print *,'TV ',(tv(i),i=1,nl)
+c sb3d      print *, 'P ',(p(i),i=1,nl)
+c sb3d      print *,'ICB ',icb
+C
+C   ***   MAKE SURE THAT COLUMN IS DRY ADIABATIC BETWEEN THE SURFACE  ***
+C   ***    AND CLOUD BASE, AND THAT LIFTED AIR IS POSITIVELY BUOYANT  ***
+C   ***                         AT CLOUD BASE                         ***
+C   ***       IF NOT, RETURN TO CALLING PROGRAM AFTER RESETTING       ***
+C   ***                        SIG(I) AND W0(I)                       ***
+C
+Cjyg
+CCC      TDIF=TVP(ICB)-TV(ICB)
+      TDIF = BUOY(ICB)
+      ATH1=TH(1)
+Cjyg
+CCC      ATH=TH(ICB-1)-1.0
+      ATH=TH(ICB-1)-5.0
+c      ATH=0.                          ! ajout sb
+c      IF (ICB.GT.1) ATH=TH(ICB-1)-5.0 ! modif sb
+      IF(TDIF.LT.DTCRIT.OR.ATH.GT.ATH1)THEN
+         DO 60 I=1,NL
+            SIG(I)=BETA*SIG(I)-2.*ALPHA*TDIF*TDIF
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   60    CONTINUE
+         IFLAG=0
+         RETURN
+      END IF
+C
+ 
+ 
+C   ***  IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
+C   ***        NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS       ***
+C
+      DO 70 I=1,NL
+         HP(I)=H(I)
+         WT(I)=0.001
+         RP(I)=RR(I)
+         UP(I)=U(I)
+         VP(I)=V(I)
+         DO 71 J=1,NTRA
+          TRAP(I,J)=TRA(I,J)
+   71    CONTINUE
+         NENT(I)=0
+         WATER(I)=0.0
+         EVAP(I)=0.0
+         B(I)=0.0
+         MP(I)=0.0
+         M(I)=0.0
+         LV(I)=ALV0-CPVMCL*(T(I)-273.15)
+         LVCP(I)=LV(I)/CPN(I)
+         DO 70 J=1,NL
+            QENT(I,J)=RR(J)
+            ELIJ(I,J)=0.0
+            MENT(I,J)=0.0
+            SIJ(I,J)=0.0
+          UENT(I,J)=U(J)
+          VENT(I,J)=V(J)
+          DO 70 K=1,NTRA
+           TRAENT(I,J,K)=TRA(J,K)
+   70 CONTINUE
+ 
+      DELTI=1.0/DELT
+C
+C  ***  FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S       ***
+C  ***                LEVEL OF NEUTRAL BUOYANCY                   ***
+C
+      INB=NL-1
+      DO 80 I=ICB,NL-1
+Cjyg
+CCC         IF((TVP(I)-TV(I)).LT.DTCRIT)THEN
+         IF(BUOY(I).LT.DTOVSH)THEN
+            INB=MIN(INB,I)
+         END IF
+   80 CONTINUE
+ 
+ 
+ 
+ 
+C
+C   ***          RESET SIG(I) AND W0(I) FOR I>INB AND I<ICB       ***
+C
+      IF(INB.LT.(NL-1))THEN
+         DO 85 I=INB+1,NL-1
+Cjyg
+CCC            SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(INB)-TVP(INB))*
+CCC     1              ABS(TV(INB)-TVP(INB))
+            SIG(I)=BETA*SIG(I)+2.*ALPHA*BUOY(INB)*
+     1              ABS(BUOY(INB))
+            SIG(I)=AMAX1(SIG(I),0.0)
+            W0(I)=BETA*W0(I)
+   85    CONTINUE
+      END IF
+      DO 87 I=1,ICB
+Cjyg
+CCC         SIG(I)=BETA*SIG(I)-2.0E-4*ALPHA*(TV(ICB)-TVP(ICB))*
+CCC     1           (TV(ICB)-TVP(ICB))
+         SIG(I)=BETA*SIG(I)-2.*ALPHA*BUOY(ICB)*BUOY(ICB)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         W0(I)=BETA*W0(I)
+   87 CONTINUE
+C
+C   ***    RESET FRACTIONAL AREAS OF UPDRAFTS AND W0 AT INITIAL TIME    ***
+C   ***           AND AFTER 10 TIME STEPS OF NO CONVECTION              ***
+C
+ 
+      IF(SIG(ND).LT.1.5.OR.SIG(ND).GT.12.0)THEN
+         DO 90 I=1,NL-1
+            SIG(I)=0.0
+            W0(I)=0.0
+   90    CONTINUE
+      END IF
+C
+C   ***   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL   ***
+C
+      DO 95 I=ICB,INB
+         HP(I)=H(1)+(LV(I)+(CPD-CPV)*T(I))*EP(I)*CLW(I)
+   95 CONTINUE
+C
+C   ***  CALCULATE CONVECTIVE AVAILABLE POTENTIAL ENERGY (CAPE),  ***
+C   ***     VERTICAL VELOCITY (W), FRACTIONAL AREA COVERED BY     ***
+C   ***     UNDILUTE UPDRAFT (SIG),  AND UPDRAFT MASS FLUX (M)    ***
+C
+      CAPE=0.0
+C
+      DO 98 I=ICB+1,INB
+Cjyg1
+CCC         CAPE=CAPE+RD*(TVP(I-1)-TV(I-1))*(PH(I-1)-PH(I))/P(I-1)
+CCC         DCAPE=RD*BUOY(I-1)*(PH(I-1)-PH(I))/P(I-1)
+CCC         DLNP=(PH(I-1)-PH(I))/P(I-1)
+C          The interval on which CAPE is computed starts at PBASE :
+         DELTAP = MIN(PBASE,PH(I-1))-MIN(PBASE,PH(I))
+         CAPE=CAPE+RD*BUOY(I-1)*DELTAP/P(I-1)
+         DCAPE=RD*BUOY(I-1)*DELTAP/P(I-1)
+         DLNP=DELTAP/P(I-1)
+Cjyg2
+c sb3d         print *,'buoy,dlnp,dcape,cape',buoy(i-1),dlnp,dcape,cape
+         CAPE=AMAX1(0.0,CAPE)
+C
+         SIGOLD=SIG(I)
+         DTMIN=100.0
+         DO 97 J=ICB,I-1
+Cjyg
+CCC            DTMIN=AMIN1(DTMIN,(TVP(J)-TV(J)))
+            DTMIN=AMIN1(DTMIN,BUOY(J))
+   97    CONTINUE
+c sb3d     print *, 'DTMIN, BETA, ALPHA, SIG = ',DTMIN,BETA,ALPHA,SIG(I)
+         SIG(I)=BETA*SIG(I)+ALPHA*DTMIN*ABS(DTMIN)
+         SIG(I)=AMAX1(SIG(I),0.0)
+         SIG(I)=AMIN1(SIG(I),0.01)
+         FAC=AMIN1(((DTCRIT-DTMIN)/DTCRIT),1.0)
+Cjyg
+CC    Essais de reduction de la vitesse
+CC         FAC = FAC*.5
+C
+         W=(1.-BETA)*FAC*SQRT(CAPE)+BETA*W0(I)
+         AMU=0.5*(SIG(I)+SIGOLD)*W
+         M(I)=AMU*0.007*P(I)*(PH(I)-PH(I+1))/TV(I)
+         W0(I)=W
+   98 CONTINUE
+      W0(ICB)=0.5*W0(ICB+1)
+      M(ICB)=0.5*M(ICB+1)*(PH(ICB)-PH(ICB+1))/(PH(ICB+1)-PH(ICB+2))
+      SIG(ICB)=SIG(ICB+1)
+      SIG(ICB-1)=SIG(ICB)
+cjyg1
+c sb3d      print *, 'Cloud base, c. top, CAPE',ICB,INB,cape
+c sb3d      print *, 'SIG ',(sig(i),i=1,inb)
+c sb3d      print *, 'W ',(w0(i),i=1,inb)
+c sb3d      print *, 'M ',(m(i), i=1,inb)
+c sb3d      print *, 'Dt1 ',(tvp(i)-tv(i),i=1,inb)
+c sb3d      print *, 'Dt_vrai ',(buoy(i),i=1,inb)
+Cjyg2
+C
+C   ***  CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING  ***
+C   ***     RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING     ***
+C   ***                        FRACTION (SIJ)                          ***
+C
+ 
+ 
+      DO 170 I=ICB,INB
+         RTI=RR(1)-EP(I)*CLW(I)
+         DO 160 J=ICB-1,INB
+            BF2=1.+LV(J)*LV(J)*RS(J)/(RV*T(J)*T(J)*CPD)
+            ANUM=H(J)-HP(I)+(CPV-CPD)*T(J)*(RTI-RR(J))
+            DENOM=H(I)-HP(I)+(CPD-CPV)*(RR(I)-RTI)*T(J)
+            DEI=DENOM
+            IF(ABS(DEI).LT.0.01)DEI=0.01
+            SIJ(I,J)=ANUM/DEI
+            SIJ(I,I)=1.0
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM/BF2
+            CWAT=CLW(J)*(1.-EP(J))
+            STEMP=SIJ(I,J)
+            IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR.
+     1      ALTEM.GT.CWAT).AND.J.GT.I)THEN
+            ANUM=ANUM-LV(J)*(RTI-RS(J)-CWAT*BF2)
+            DENOM=DENOM+LV(J)*(RR(I)-RTI)
+            IF(ABS(DENOM).LT.0.01)DENOM=0.01
+            SIJ(I,J)=ANUM/DENOM
+            ALTEM=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI-RS(J)
+            ALTEM=ALTEM-(BF2-1.)*CWAT
+            END IF
+ 
+ 
+            IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.95)THEN
+               QENT(I,J)=SIJ(I,J)*RR(I)+(1.-SIJ(I,J))*RTI
+               UENT(I,J)=SIJ(I,J)*U(I)+(1.-SIJ(I,J))*U(NK)
+               VENT(I,J)=SIJ(I,J)*V(I)+(1.-SIJ(I,J))*V(NK)
+               DO K=1,NTRA
+               TRAENT(I,J,K)=SIJ(I,J)*TRA(I,K)+(1.-SIJ(I,J))*
+     1         TRA(NK,K)
+               END DO
+               ELIJ(I,J)=ALTEM
+               ELIJ(I,J)=AMAX1(0.0,ELIJ(I,J))
+               MENT(I,J)=M(I)/(1.-SIJ(I,J))
+               NENT(I)=NENT(I)+1
+            END IF
+            SIJ(I,J)=AMAX1(0.0,SIJ(I,J))
+            SIJ(I,J)=AMIN1(1.0,SIJ(I,J))
+  160    CONTINUE
+C
+C   ***   IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS  ***
+C   ***   AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES  ***
+C
+         IF(NENT(I).EQ.0)THEN
+            MENT(I,I)=M(I)
+            QENT(I,I)=RR(NK)-EP(I)*CLW(I)
+           UENT(I,I)=U(NK)
+           VENT(I,I)=V(NK)
+           DO J=1,NTRA
+            TRAENT(I,I,J)=TRA(NK,J)
+           END DO
+            ELIJ(I,I)=CLW(I)
+            SIJ(I,I)=1.0
+         END IF
+C
+         DO J = ICB-1,INB
+           SIGIJ(I,J) = SIJ(I,J)
+         ENDDO
+C	
+  170 CONTINUE
+C
+C   ***  NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL  ***
+C   ***              PROBABILITIES OF MIXING                     ***
+C
+ 
+      DO 200 I=ICB,INB
+      IF(NENT(I).NE.0)THEN
+       QP=RR(1)-EP(I)*CLW(I)
+       ANUM=H(I)-HP(I)-LV(I)*(QP-RS(I))+(CPV-CPD)*T(I)*
+     1    (QP-RR(I))
+       DENOM=H(I)-HP(I)+LV(I)*(RR(I)-QP)+
+     1    (CPD-CPV)*T(I)*(RR(I)-QP)
+       IF(ABS(DENOM).LT.0.01)DENOM=0.01
+       SCRIT=ANUM/DENOM
+       ALT=QP-RS(I)+SCRIT*(RR(I)-QP)
+       IF(SCRIT.LE.0.0.OR.ALT.LE.0.0)SCRIT=1.0
+       SMAX=0.0
+       ASIJ=0.0
+        DO 175 J=INB,ICB-1,-1
+        IF(SIJ(I,J).GT.1.0E-16.AND.SIJ(I,J).LT.0.95)THEN
+         WGH=1.0
+         IF(J.GT.I)THEN
+          SJMAX=AMAX1(SIJ(I,J+1),SMAX)
+          SJMAX=AMIN1(SJMAX,SCRIT)
+          SMAX=AMAX1(SIJ(I,J),SMAX)
+          SJMIN=AMAX1(SIJ(I,J-1),SMAX)
+          SJMIN=AMIN1(SJMIN,SCRIT)
+          IF(SIJ(I,J).LT.(SMAX-1.0E-16))WGH=0.0
+          SMID=AMIN1(SIJ(I,J),SCRIT)
+         ELSE
+          SJMAX=AMAX1(SIJ(I,J+1),SCRIT)
+          SMID=AMAX1(SIJ(I,J),SCRIT)
+          SJMIN=0.0
+          IF(J.GT.1)SJMIN=SIJ(I,J-1)
+          SJMIN=AMAX1(SJMIN,SCRIT)
+         END IF
+         DELP=ABS(SJMAX-SMID)
+         DELM=ABS(SJMIN-SMID)
+         ASIJ=ASIJ+WGH*(DELP+DELM)
+         MENT(I,J)=MENT(I,J)*(DELP+DELM)*WGH
+        END IF
+  175       CONTINUE
+       ASIJ=AMAX1(1.0E-16,ASIJ)
+       ASIJ=1.0/ASIJ
+       DO 180 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASIJ
+  180    CONTINUE
+       ASUM=0.0
+       BSUM=0.0
+       DO 190 J=ICB-1,INB
+        ASUM=ASUM+MENT(I,J)
+        MENT(I,J)=MENT(I,J)*SIG(J)
+        BSUM=BSUM+MENT(I,J)
+  190       CONTINUE
+       BSUM=AMAX1(BSUM,1.0E-16)
+       BSUM=1.0/BSUM
+       DO 195 J=ICB-1,INB
+        MENT(I,J)=MENT(I,J)*ASUM*BSUM	
+  195       CONTINUE
+       CSUM=0.0
+       DO 197 J=ICB-1,INB
+        CSUM=CSUM+MENT(I,J)
+  197       CONTINUE
+ 
+       IF(CSUM.LT.M(I))THEN
+        NENT(I)=0
+        MENT(I,I)=M(I)
+        QENT(I,I)=RR(1)-EP(I)*CLW(I)
+          UENT(I,I)=U(NK)
+          VENT(I,I)=V(NK)
+          DO J=1,NTRA
+           TRAENT(I,I,J)=TRA(NK,J)
+          END DO
+        ELIJ(I,I)=CLW(I)
+        SIJ(I,I)=1.0
+       END IF
+      END IF
+  200      CONTINUE
+ 
+ 
+ 
+***************************************************************
+**       CALCUL DES MENTS(I,J) ET DES QENTS(I,J)
+**************************************************************
+ 
+         DO im=1,nd
+         do jm=1,nd
+ 
+         QENTS(im,jm)=QENT(im,jm)
+         MENTS(im,jm)=MENT(im,jm)
+         enddo
+         enddo
+ 
+***********************************************************
+ 
+ 
+ 
+C
+C   ***  CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING    ***
+C   ***             DOWNDRAFT CALCULATION                      ***
+C
+        IF(EP(INB).LT.0.0001)GOTO 405
+C
+C   ***  INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER   ***
+C   ***                AND CONDENSED WATER FLUX                    ***
+C
+        WFLUX=0.0
+        TINV=1./3.
+C
+C    ***                    BEGIN DOWNDRAFT LOOP                    ***
+C
+        DO 400 I=INB,1,-1
+C
+C    ***              CALCULATE DETRAINED PRECIPITATION             ***
+C
+ 
+ 
+        WDTRAIN=10.0*EP(I)*M(I)*CLW(I)
+        IF(I.GT.1)THEN
+         DO 320 J=1,I-1
+       AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+  320    WDTRAIN=WDTRAIN+10.0*AWAT*MENT(J,I)
+        END IF
+C
+C    ***    FIND RAIN WATER AND EVAPORATION USING PROVISIONAL   ***
+C    ***              ESTIMATES OF RP(I)AND RP(I-1)             ***
+C
+ 
+ 
+        WT(I)=45.0
+      IF(I.LT.INB)THEN
+       RP(I)=RP(I+1)+(CPD*(T(I+1)-T(I))+GZ(I+1)-GZ(I))/LV(I)
+       RP(I)=0.5*(RP(I)+RR(I))
+      END IF
+      RP(I)=AMAX1(RP(I),0.0)
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(INB)=RR(INB)
+      IF(I.EQ.1)THEN
+       AFAC=P(1)*(RS(1)-RP(1))/(1.0E4+2000.0*P(1)*RS(1))
+      ELSE
+       RP(I-1)=RP(I)+(CPD*(T(I)-T(I-1))+GZ(I)-GZ(I-1))/LV(I)
+       RP(I-1)=0.5*(RP(I-1)+RR(I-1))
+       RP(I-1)=AMIN1(RP(I-1),RS(I-1))
+       RP(I-1)=AMAX1(RP(I-1),0.0)
+       AFAC1=P(I)*(RS(I)-RP(I))/(1.0E4+2000.0*P(I)*RS(I))
+       AFAC2=P(I-1)*(RS(I-1)-RP(I-1))/(1.0E4+
+     1    2000.0*P(I-1)*RS(I-1))
+       AFAC=0.5*(AFAC1+AFAC2)
+      END IF
+      IF(I.EQ.INB)AFAC=0.0
+        AFAC=AMAX1(AFAC,0.0)
+        BFAC=1./(SIGD*WT(I))
+C
+Cjyg1
+CCC        SIGT=1.0
+CCC        IF(I.GE.ICB)SIGT=SIGP(I)
+C Prise en compte de la variation progressive de SIGT dans
+C les couches ICB et ICB-1:
+C 	Pour PLCL<PH(I+1), PR1=0 & PR2=1
+C 	Pour PLCL>PH(I),   PR1=1 & PR2=0
+C 	Pour PH(I+1)<PLCL<PH(I), PR1 est la proportion a cheval
+C    sur le nuage, et PR2 est la proportion sous la base du
+C    nuage.
+         PR1 =(PLCL-PH(I+1))/(PH(I)-PH(I+1))
+         PR1 = MAX(0.,MIN(1.,PR1))
+         PR2 = (PH(I)-PLCL)/(PH(I)-PH(I+1))
+         PR2 = MAX(0.,MIN(1.,PR2))
+         SIGT = SIGP(I)*PR1 + PR2
+c sb3d         print *,'i,sigt,pr1,pr2', i,sigt,pr1,pr2
+Cjyg2
+C
+        B6=BFAC*50.*SIGD*(PH(I)-PH(I+1))*SIGT*AFAC
+        C6=WATER(I+1)+BFAC*WDTRAIN-50.*SIGD*BFAC*
+     1   (PH(I)-PH(I+1))*EVAP(I+1)
+      IF(C6.GT.0.0)THEN
+         REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
+         EVAP(I)=SIGT*AFAC*REVAP
+         WATER(I)=REVAP*REVAP
+      ELSE
+       EVAP(I)=-EVAP(I+1)+0.02*(WDTRAIN+SIGD*WT(I)*
+     1    WATER(I+1))/(SIGD*(PH(I)-PH(I+1)))
+      END IF
+ 
+ 
+C
+C    ***  CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER     ***
+C    ***              HYDROSTATIC APPROXIMATION                 ***
+C
+        IF(I.EQ.1)GOTO 360
+      TEVAP=AMAX1(0.0,EVAP(I))
+      DELTH=AMAX1(0.001,(TH(I)-TH(I-1)))
+      MP(I)=10.*LVCP(I)*SIGD*TEVAP*(P(I-1)-P(I))/DELTH
+C
+C    ***           IF HYDROSTATIC ASSUMPTION FAILS,             ***
+C    ***   SOLVE CUBIC DIFFERENCE EQUATION FOR DOWNDRAFT THETA  ***
+C    ***  AND MASS FLUX FROM TWO SIMULTANEOUS DIFFERENTIAL EQNS ***
+C
+      AMFAC=SIGD*SIGD*70.0*PH(I)*(P(I-1)-P(I))*
+     1   (TH(I)-TH(I-1))/(TV(I)*TH(I))
+      AMP2=ABS(MP(I+1)*MP(I+1)-MP(I)*MP(I))
+      IF(AMP2.GT.(0.1*AMFAC))THEN
+         XF=100.0*SIGD*SIGD*SIGD*(PH(I)-PH(I+1))
+         TF=B(I)-5.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         AF=XF*TF+MP(I+1)*MP(I+1)*TINV
+         BF=2.*(TINV*MP(I+1))**3+TINV*MP(I+1)*XF*TF+50.*
+     1    (P(I-1)-P(I))*XF*TEVAP
+         FAC2=1.0
+         IF(BF.LT.0.0)FAC2=-1.0
+         BF=ABS(BF)
+         UR=0.25*BF*BF-AF*AF*AF*TINV*TINV*TINV
+         IF(UR.GE.0.0)THEN
+          SRU=SQRT(UR)
+          FAC=1.0
+          IF((0.5*BF-SRU).LT.0.0)FAC=-1.0
+          MP(I)=MP(I+1)*TINV+(0.5*BF+SRU)**TINV+
+     1     FAC*(ABS(0.5*BF-SRU))**TINV
+         ELSE
+          D=ATAN(2.*SQRT(-UR)/(BF+1.0E-28))
+          IF(FAC2.LT.0.0)D=3.14159-D
+          MP(I)=MP(I+1)*TINV+2.*SQRT(AF*TINV)*COS(D*TINV)
+         END IF
+         MP(I)=AMAX1(0.0,MP(I))
+         B(I-1)=B(I)+100.0*(P(I-1)-P(I))*TEVAP/(MP(I)+SIGD*0.1)-
+     1    10.0*(TH(I)-TH(I-1))*T(I)/(LVCP(I)*SIGD*TH(I))
+         B(I-1)=AMAX1(B(I-1),0.0)
+      END IF
+ 
+ 
+C
+C   ***         LIMIT MAGNITUDE OF MP(I) TO MEET CFL CONDITION      ***
+C
+      AMPMAX=2.0*(PH(I)-PH(I+1))*DELTI
+      AMP2=2.0*(PH(I-1)-PH(I))*DELTI
+      AMPMAX=AMIN1(AMPMAX,AMP2)
+      MP(I)=AMIN1(MP(I),AMPMAX)
+C
+C    ***      FORCE MP TO DECREASE LINEARLY TO ZERO                 ***
+C    ***       BETWEEN CLOUD BASE AND THE SURFACE                   ***
+C
+          IF(P(I).GT.P(ICB))THEN
+           MP(I)=MP(ICB)*(P(1)-P(I))/(P(1)-P(ICB))
+          END IF
+  360   CONTINUE
+C
+C    ***       FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT     ***
+C
+        IF(I.EQ.INB)GOTO 400
+      RP(I)=RR(I)
+        IF(MP(I).GT.MP(I+1))THEN
+        RP(I)=RP(I+1)*MP(I+1)+RR(I)*(MP(I)-MP(I+1))+
+     1       5.*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+EVAP(I))
+        RP(I)=RP(I)/MP(I)
+          UP(I)=UP(I+1)*MP(I+1)+U(I)*(MP(I)-MP(I+1))
+         UP(I)=UP(I)/MP(I)
+          VP(I)=VP(I+1)*MP(I+1)+V(I)*(MP(I)-MP(I+1))
+         VP(I)=VP(I)/MP(I)
+          DO J=1,NTRA
+           TRAP(I,J)=TRAP(I+1,J)*MP(I+1)+
+     s     TRAP(I,J)*(MP(I)-MP(I+1))
+           TRAP(I,J)=TRAP(I,J)/MP(I)
+          END DO
+        ELSE
+        IF(MP(I+1).GT.1.0E-16)THEN
+           RP(I)=RP(I+1)+5.0*SIGD*(PH(I)-PH(I+1))*(EVAP(I+1)+
+     1      EVAP(I))/MP(I+1)
+            UP(I)=UP(I+1)
+            VP(I)=VP(I+1)
+            DO J=1,NTRA
+             TRAP(I,J)=TRAP(I+1,J)
+            END DO
+        END IF
+        END IF
+      RP(I)=AMIN1(RP(I),RS(I))
+      RP(I)=AMAX1(RP(I),0.0)
+  400   CONTINUE
+C
+C   ***  CALCULATE SURFACE PRECIPITATION IN MM/DAY     ***
+C
+        PRECIP=WT(1)*SIGD*WATER(1)*8640.0
+  405   CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE  ***
+C   ***                      AND MIXING RATIO                        ***
+C
+      DPINV=1.0/(PH(1)-PH(2))
+        AM=0.0
+        DO 410 K=2,INB
+  410   AM=AM+M(K)
+      IF((0.1*DPINV*AM).GE.DELTI)IFLAG=4
+      FT(1)=0.1*DPINV*AM*(T(2)-T(1)+(GZ(2)-GZ(1))/CPN(1))
+        FT(1)=FT(1)-0.5*LVCP(1)*SIGD*(EVAP(1)+EVAP(2))
+        FT(1)=FT(1)-0.09*SIGD*MP(2)*T(1)*B(1)*DPINV
+      FT(1)=FT(1)+0.01*SIGD*WT(1)*(CL-CPD)*WATER(2)*(T(2)-
+     1   T(1))*DPINV/CPN(1)
+        FR(1)=0.1*MP(2)*(RP(2)-RR(1))*
+     1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+        FR(1)=FR(1)+0.1*AM*(RR(2)-RR(1))*DPINV
+        FU(1)=FU(1)+0.1*DPINV*(MP(2)*(UP(2)-U(1))+AM*(U(2)-U(1)))
+        FV(1)=FV(1)+0.1*DPINV*(MP(2)*(VP(2)-V(1))+AM*(V(2)-V(1)))
+        DO J=1,NTRA
+         FTRA(1,J)=FTRA(1,J)+0.1*DPINV*(MP(2)*(TRAP(2,J)-TRA(1,J))+
+     1    AM*(TRA(2,J)-TRA(1,J)))
+        END DO
+        AMDE=0.0
+        DO 415 J=2,INB
+         FR(1)=FR(1)+0.1*DPINV*MENT(J,1)*(QENT(J,1)-RR(1))
+         FU(1)=FU(1)+0.1*DPINV*MENT(J,1)*(UENT(J,1)-U(1))
+         FV(1)=FV(1)+0.1*DPINV*MENT(J,1)*(VENT(J,1)-V(1))
+         DO K=1,NTRA
+          FTRA(1,K)=FTRA(1,K)+0.1*DPINV*MENT(J,1)*(TRAENT(J,1,K)-
+     1     TRA(1,K))
+         END DO
+  415      CONTINUE
+C
+C   ***  CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO  ***
+C   ***               AT LEVELS ABOVE THE LOWEST LEVEL                   ***
+C
+C   ***  FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES  ***
+C   ***                      THROUGH EACH LEVEL                          ***
+C
+ 
+ 
+        DO 500 I=2,INB
+        DPINV=1.0/(PH(I)-PH(I+1))
+      CPINV=1.0/CPN(I)
+        AMP1=0.0
+        DO 440 K=I+1,INB+1
+  440   AMP1=AMP1+M(K)
+        DO 450 K=1,I
+        DO 450 J=I+1,INB+1
+         AMP1=AMP1+MENT(K,J)
+  450   CONTINUE
+      IF((0.1*DPINV*AMP1).GE.DELTI)IFLAG=4
+        AD=0.0
+        DO 470 K=1,I-1
+        DO 470 J=I,INB
+  470   AD=AD+MENT(J,K)
+      FT(I)=0.1*DPINV*(AMP1*(T(I+1)-T(I)+(GZ(I+1)-GZ(I))*
+     1   CPINV)-AD*(T(I)-T(I-1)+(GZ(I)-GZ(I-1))*CPINV))
+     2   -0.5*SIGD*LVCP(I)*(EVAP(I)+EVAP(I+1))
+      RAT=CPN(I-1)*CPINV
+        FT(I)=FT(I)-0.09*SIGD*(MP(I+1)*T(I)*
+     1    B(I)-MP(I)*T(I-1)*RAT*B(I-1))*DPINV
+      FT(I)=FT(I)+0.1*DPINV*MENT(I,I)*(HP(I)-H(I)+
+     1    T(I)*(CPV-CPD)*(RR(I)-QENT(I,I)))*CPINV
+      FT(I)=FT(I)+0.01*SIGD*WT(I)*(CL-CPD)*WATER(I+1)*
+     1    (T(I+1)-T(I))*DPINV*CPINV
+        FR(I)=0.1*DPINV*(AMP1*(RR(I+1)-RR(I))-
+     1    AD*(RR(I)-RR(I-1)))
+        FU(I)=FU(I)+0.1*DPINV*(AMP1*(U(I+1)-U(I))-
+     1    AD*(U(I)-U(I-1)))
+        FV(I)=FV(I)+0.1*DPINV*(AMP1*(V(I+1)-V(I))-
+     1    AD*(V(I)-V(I-1)))
+        DO K=1,NTRA
+         FTRA(I,K)=FTRA(I,K)+0.1*DPINV*(AMP1*(TRA(I+1,K)-
+     1    TRA(I,K))-AD*(TRA(I,K)-TRA(I-1,K)))
+        END DO
+        DO 480 K=1,I-1
+       AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
+       AWAT=AMAX1(AWAT,0.0)
+         FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-AWAT
+     1    -RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  480   CONTINUE
+      DO 490 K=I,INB
+       FR(I)=FR(I)+0.1*DPINV*MENT(K,I)*(QENT(K,I)-RR(I))
+         FU(I)=FU(I)+0.1*DPINV*MENT(K,I)*(UENT(K,I)-U(I))
+         FV(I)=FV(I)+0.1*DPINV*MENT(K,I)*(VENT(K,I)-V(I))
+         DO J=1,NTRA
+          FTRA(I,J)=FTRA(I,J)+0.1*DPINV*MENT(K,I)*(TRAENT(K,I,J)-
+     1     TRA(I,J))
+         END DO
+  490      CONTINUE
+        FR(I)=FR(I)+0.5*SIGD*(EVAP(I)+EVAP(I+1))+0.1*(MP(I+1)*
+     1    (RP(I+1)-RR(I))-MP(I)*(RP(I)-RR(I-1)))*DPINV
+        FU(I)=FU(I)+0.1*(MP(I+1)*(UP(I+1)-U(I))-MP(I)*
+     1    (UP(I)-U(I-1)))*DPINV
+        FV(I)=FV(I)+0.1*(MP(I+1)*(VP(I+1)-V(I))-MP(I)*
+     1    (VP(I)-V(I-1)))*DPINV
+        DO J=1,NTRA
+         FTRA(I,J)=FTRA(I,J)+0.1*DPINV*(MP(I+1)*(TRAP(I+1,J)-TRA(I,J))-
+     1    MP(I)*(TRAP(I,J)-TRAP(I-1,J)))
+        END DO
+  500   CONTINUE
+ 
+ 
+ 
+C
+C   ***   MOVE THE DETRAINMENT AT LEVEL INB DOWN TO LEVEL INB-1   ***
+C   ***        IN SUCH A WAY AS TO PRESERVE THE VERTICALLY        ***
+C   ***          INTEGRATED ENTHALPY AND WATER TENDENCIES         ***
+C
+      AX=0.1*MENT(INB,INB)*(HP(INB)-H(INB)+T(INB)*
+     1    (CPV-CPD)*(RR(INB)-QENT(INB,INB)))/(CPN(INB)*
+     2    (PH(INB)-PH(INB+1)))
+      FT(INB)=FT(INB)-AX
+      FT(INB-1)=FT(INB-1)+AX*CPN(INB)*(PH(INB)-PH(INB+1))/
+     1    (CPN(INB-1)*(PH(INB-1)-PH(INB)))
+      BX=0.1*MENT(INB,INB)*(QENT(INB,INB)-RR(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FR(INB)=FR(INB)-BX
+      FR(INB-1)=FR(INB-1)+BX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      CX=0.1*MENT(INB,INB)*(UENT(INB,INB)-U(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FU(INB)=FU(INB)-CX
+      FU(INB-1)=FU(INB-1)+CX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DX=0.1*MENT(INB,INB)*(VENT(INB,INB)-V(INB))/
+     1    (PH(INB)-PH(INB+1))
+      FV(INB)=FV(INB)-DX
+      FV(INB-1)=FV(INB-1)+DX*(PH(INB)-PH(INB+1))/
+     1    (PH(INB-1)-PH(INB))
+      DO J=1,NTRA
+      EX=0.1*MENT(INB,INB)*(TRAENT(INB,INB,J)
+     1    -TRA(INB,J))/(PH(INB)-PH(INB+1))
+      FTRA(INB,J)=FTRA(INB,J)-EX
+      FTRA(INB-1,J)=FTRA(INB-1,J)+EX*
+     1     (PH(INB)-PH(INB+1))/(PH(INB-1)-PH(INB))
+      ENDDO   
+C
+C   ***    HOMOGINIZE TENDENCIES BELOW CLOUD BASE    ***
+C
+      ASUM=0.0
+      BSUM=0.0
+      CSUM=0.0
+        DSUM=0.0
+      DO 650 I=1,ICB-1
+       ASUM=ASUM+FT(I)*(PH(I)-PH(I+1))
+         BSUM=BSUM+FR(I)*(LV(I)+(CL-CPD)*(T(I)-T(1)))*
+     1    (PH(I)-PH(I+1))
+       CSUM=CSUM+(LV(I)+(CL-CPD)*(T(I)-T(1)))*(PH(I)-PH(I+1))
+       DSUM=DSUM+T(I)*(PH(I)-PH(I+1))/TH(I)
+  650      CONTINUE
+      DO 700 I=1,ICB-1
+       FT(I)=ASUM*T(I)/(TH(I)*DSUM)
+       FR(I)=BSUM/CSUM
+  700      CONTINUE
+C
+C   ***           RESET COUNTER AND RETURN           ***
+C
+      SIG(ND)=2.0
+c
+c
+      do i = 1, nd
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+c sb       dnwd0(i) = - mp(i)
+      enddo
+c
+      do i = 1, nl
+       dnwd0(i) = - mp(i)
+      enddo
+      do i = nl+1, nd
+       dnwd0(i) = 0.
+      enddo
+c
+      do i = icb, inb
+         upwd(i) = 0.0
+         dnwd(i) = 0.0
+
+         do k =i, inb
+            up1=0.0
+            dn1=0.0
+            do n = 1, i-1
+               up1 = up1 + ment(n,k)
+               dn1 = dn1 - ment(k,n)
+            enddo
+            upwd(i) = upwd(i)+ m(k) + up1
+            dnwd(i) = dnwd(i) + dn1
+         enddo
+        enddo
+ 
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        DETERMINATION DE LA VARIATION DE FLUX ASCENDANT ENTRE
+C        DEUX NIVEAU NON DILUE Mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+c sb      do i=1,ND
+c sb      Mike(i)=M(i)
+c sb      enddo
+ 
+      do i = 1, NL
+       Mike(i) = M(i)
+      enddo
+      do i = NL+1, ND
+       Mike(i) = 0.
+      enddo
+ 
+      do i=1,nd
+      Ma(i)=0
+      enddo
+ 
+c sb      do i=1,nd
+c sb      do j=i,nd
+c sb      Ma(i)=Ma(i)+M(j)
+c sb      enddo
+c sb      enddo
+
+      do i = 1, NL
+      do j = i, NL
+       Ma(i) = Ma(i) + M(j)
+      enddo
+      enddo
+c
+      do i = NL+1, ND
+       Ma(i) = 0.
+      enddo
+c 
+      do i=1,ICB-1
+      Ma(i)=0
+      enddo
+ 
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C        ICB REPRESENTE DE NIVEAU OU SE TROUVE LA
+c        BASE DU NUAGE , ET INB LE TOP DU NUAGE
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ 
+ 
+       do i=1,ND
+       Mke(i)=upwd(i)+dnwd(i)
+       enddo
+c$$$cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c$$$         call writeg1d(1,klev,ma,'ma  ','ma  ')
+c$$$          call writeg1d(1,klev,upwd,'upwd  ','upwd  ')
+c$$$          call writeg1d(1,klev,dnwd,'dnwd  ','dnwd  ')
+c$$$          call writeg1d(1,klev,dnwd0,'dnwd0  ','dnwd0  ')
+c$$$          call writeg1d(1,klev,tvp,'tvp  ','tvp  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,3),'tra3  ','tra3  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,4),'tra4  ','tra4  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,5),'tra5  ','tra5  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,6),'tra6  ','tra6  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,7),'tra7  ','tra7  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,8),'tra8  ','tra8  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,9),'tra9  ','tra9  ')
+c$$$          call writeg1d(1,klev,tra(1:klev,10),'tra10','tra10')
+c$$$          call writeg1d(1,klev,tra(1:klev,11),'tra11','tra11')
+c$$$          call writeg1d(1,klev,tra(1:klev,12),'tra12','tra12')
+c$$$          call writeg1d(1,klev,tra(1:klev,13),'tra13','tra13')
+c$$$          call writeg1d(1,klev,tra(1:klev,14),'tra14','tra14')
+c$$$          call writeg1d(1,klev,tra(1:klev,15),'tra15','tra15')
+c$$$          call writeg1d(1,klev,tra(1:klev,16),'tra16','tra16')
+c$$$          call writeg1d(1,klev,tra(1:klev,17),'tra17','tra17')
+c$$$          call writeg1d(1,klev,tra(1:klev,18),'tra18','tra18')
+c$$$          call writeg1d(1,klev,tra(1:klev,19),'tra19','tra19')
+c$$$          call writeg1d(1,klev,tra(1:klev,20),'tra20','tra20 ')
+c$$$          call writeg1d(1,klev,trap(1:klev,1),'trp1','trp1')
+c$$$          call writeg1d(1,klev,trap(1:klev,2),'trp2','trp2')
+c$$$          call writeg1d(1,klev,trap(1:klev,3),'trp3','trp3')
+c$$$          call writeg1d(1,klev,trap(1:klev,4),'trp4','trp4')
+c$$$          call writeg1d(1,klev,trap(1:klev,5),'trp5','trp5')
+c$$$          call writeg1d(1,klev,trap(1:klev,10),'trp10','trp10')
+c$$$          call writeg1d(1,klev,trap(1:klev,12),'trp12','trp12')
+c$$$          call writeg1d(1,klev,trap(1:klev,15),'trp15','trp15')
+c$$$          call writeg1d(1,klev,trap(1:klev,20),'trp20','trp20')
+c$$$          call writeg1d(1,klev,ftra(1:klev,1),'ftr1  ','ftr1  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,2),'ftr2  ','ftr2  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,3),'ftr3  ','ftr3  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,4),'ftr4  ','ftr4  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,5),'ftr5  ','ftr5  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,6),'ftr6  ','ftr6  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,7),'ftr7  ','ftr7  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,8),'ftr8  ','ftr8  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,9),'ftr9  ','ftr9  ')
+c$$$          call writeg1d(1,klev,ftra(1:klev,10),'ftr10','ftr10')
+c$$$          call writeg1d(1,klev,ftra(1:klev,11),'ftr11','ftr11')
+c$$$          call writeg1d(1,klev,ftra(1:klev,12),'ftr12','ftr12')
+c$$$          call writeg1d(1,klev,ftra(1:klev,13),'ftr13','ftr13')
+c$$$          call writeg1d(1,klev,ftra(1:klev,14),'ftr14','ftr14')
+c$$$          call writeg1d(1,klev,ftra(1:klev,15),'ftr15','ftr15')
+c$$$          call writeg1d(1,klev,ftra(1:klev,16),'ftr16','ftr16')
+c$$$          call writeg1d(1,klev,ftra(1:klev,17),'ftr17','ftr17')
+c$$$          call writeg1d(1,klev,ftra(1:klev,18),'ftr18','ftr18')
+c$$$          call writeg1d(1,klev,ftra(1:klev,19),'ftr19','ftr19')
+c$$$          call writeg1d(1,klev,ftra(1:klev,20),'ftr20','ftr20 ')
+c$$$          call writeg1d(1,klev,mp,'mp  ','mp ')
+c$$$          call writeg1d(1,klev,Mke,'Mke  ','Mke ')
+
+ 
+ 
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c
+        RETURN
+        END
+C ---------------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/dimphy.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/dimphy.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/dimphy.h	(revision 300)
@@ -1,5 +1,5 @@
 c-----------------------------------------------------------------------
       INTEGER KIDIA, KFDIA, KLON, KLEV
-      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2-1/jjm,
      .           KLON=KFDIA-KIDIA+1,KLEV=llm)
 c-----------------------------------------------------------------------
@@ -7,2 +7,4 @@
       PARAMETER (nbtr=nqmx-2+1/(nqmx-1))
 c-----------------------------------------------------------------------
+      REAL zmasq(KLON)
+      COMMON/terreoce/zmasq
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/fisrtilp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/fisrtilp.F	(revision 300)
@@ -1,4 +1,5 @@
       SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,
-     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow)
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   prfl, psfl)
 c
       IMPLICIT none
@@ -28,4 +29,6 @@
       REAL rain(klon) ! pluies (mm/s)
       REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
 c
 c Options du programme:
@@ -36,5 +39,7 @@
       PARAMETER (ct=1./1800.)
       REAL cl ! seuil de precipitation
-      PARAMETER (cl=2.0e-4)
+      PARAMETER (cl=2.6e-4)
+ccc      PARAMETER (cl=2.3e-4)
+ccc      PARAMETER (cl=2.0e-4)
       INTEGER ninter ! sous-intervals pour la precipitation
       PARAMETER (ninter=5)
@@ -77,6 +82,7 @@
 #include "YOETHF.h"
 #include "FCTTRE.h"
-CCC      fallv (zzz) = 3.29/3.0 * ((zzz)**0.
-       fallv (zzz) = 3.29 * ((zzz)**0.16)
+      fallv (zzz) = 3.29/2.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29 * ((zzz)**0.16)
 c
       DATA appel1er /.TRUE./
@@ -103,4 +109,10 @@
 c Initialiser les sorties:
 c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
       DO k = 1, klev
       DO i = 1, klon
@@ -205,5 +217,6 @@
             zx = zx * zx * zx
             ratqs = zx * (rat_max-rat_min) + rat_min
-            IF (.NOT.calcrat) ratqs=0.2
+            IF (.NOT.calcrat) ratqs=0.05
+ccc            IF (.NOT.calcrat) ratqs=0.2
 c
             zdelq = ratqs * zq(i)
@@ -269,4 +282,9 @@
      .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
       ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
       ENDDO
 c
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/fisrtilp_tr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp_tr.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/fisrtilp_tr.F	(revision 300)
@@ -1,6 +1,9 @@
-      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,
+c $Header$
+c
+      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,ratqs,
      s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
      s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
-     s                   frac_impa, frac_nucl )
+     s                   frac_impa, frac_nucl,
+     s                   prfl, psfl)
 
 c
@@ -32,4 +35,6 @@
       REAL rain(klon) ! pluies (mm/s)
       REAL snow(klon) ! neige (mm/s)
+      REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+      REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
 cAA
 c Coeffients de fraction lessivee : pour OFF-LINE
@@ -53,5 +58,7 @@
       PARAMETER (ct=1./1800.)
       REAL cl ! seuil de precipitation
-      PARAMETER (cl=2.0e-4)
+      PARAMETER (cl=2.6e-4)
+ccc      PARAMETER (cl=2.3e-4)
+ccc      PARAMETER (cl=2.0e-4)
       INTEGER ninter ! sous-intervals pour la precipitation
       PARAMETER (ninter=5)
@@ -61,6 +68,6 @@
       PARAMETER (coef_eva=2.0E-05)
       LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
-      REAL ratqs ! determine la largeur de distribution de vapeur
-      PARAMETER (calcrat=.FALSE.)
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      PARAMETER (calcrat=.TRUE.)
       REAL zx_min, rat_max
       PARAMETER (zx_min=1.0, rat_max=0.01)
@@ -101,5 +108,5 @@
       REAL zalpha_tr
       REAL zfrac_lessi
-      REAL zprec_cond
+      REAL zprec_cond(klon)
 cAA
 c---------------------------------------------------------------
@@ -111,5 +118,7 @@
 #include "YOETHF.h"
 #include "FCTTRE.h"
-      fallv (zzz) = 3.29 * ((zzz)**0.16)
+      fallv (zzz) = 3.29/2.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29/3.0 * ((zzz)**0.16)
+ccc      fallv (zzz) = 3.29 * ((zzz)**0.16)
 c
       DATA appel1er /.TRUE./
@@ -158,4 +167,11 @@
 c Initialiser les sorties:
 c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         prfl(i,k) = 0.0
+         psfl(i,k) = 0.0
+      ENDDO
+      ENDDO
+
       DO k = 1, klev
       DO i = 1, klon
@@ -186,5 +202,4 @@
       zalpha_tr   = 0.
       zfrac_lessi = 0.
-      zprec_cond  = 0.
 
 cAA----------------------------------------------------------
@@ -268,12 +283,5 @@
          DO i = 1, klon
 c
-            zx = pplay(i,k)/paprs(i,1)
-            zx = (zx_max-zx)/(zx_max-zx_min)
-            zx = MIN(MAX(zx,0.0),1.0)
-            zx = zx * zx * zx
-            ratqs = zx * (rat_max-rat_min) + rat_min
-            IF (.NOT.calcrat) ratqs=0.2
-c
-            zdelq = ratqs * zq(i)
+            zdelq = ratqs(i,k) * zq(i)
             rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
             zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
@@ -337,4 +345,9 @@
      .                    * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
       ENDIF
+      IF (zt(i).LT.RTT) THEN
+        psfl(i,k)=zrfl(i)
+      ELSE
+        prfl(i,k)=zrfl(i)
+      ENDIF
       ENDDO
 c
@@ -350,7 +363,7 @@
       DO i = 1,klon
 c
-             zprec_cond = MAX(zcond(i)-zoliq(i),0.0)
+         zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0)
      .                * (paprs(i,k)-paprs(i,k+1))/RG
-         IF (rneb(i,k).GT.0.0.and.zprec_cond.gt.0.) THEN
+         IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
 cAA lessivage nucleation LMD5 dans la couche elle-meme
             if (t(i,k) .GE. ztglace) THEN
@@ -359,25 +372,30 @@
                zalpha_tr = a_tr_sca(4)
             endif
-            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond/zneb(i))
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
             pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
             frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
 c
 c nucleation avec un facteur -1 au lieu de -0.5
-            zfrac_lessi = 1. - EXP(-zprec_cond/zneb(i))
+            zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
             pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+c
 cAA Lessivage par impaction dans les couches en-dessous
-            do kk=k-1,1,-1
-              if (t(i,kk) .GE. ztglace) THEN
-                 zalpha_tr = a_tr_sca(1)
-              else
-                 zalpha_tr = a_tr_sca(2)
-              endif
-              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond/zneb(i))
-              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
-              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi 
-            enddo
-         ENDIF
-c
-      ENDDO      ! boucle sur i
+      DO kk = k-1, 1, -1
+        DO i = 1, klon
+          IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+            if (t(i,kk) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(1)
+            else
+              zalpha_tr = a_tr_sca(2)
+            endif
+            zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+            pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+            frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+          ENDIF
+        ENDDO
+      ENDDO
 c
 cAA----------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/hgardfou.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/hgardfou.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/hgardfou.F	(revision 300)
@@ -51,5 +51,6 @@
          jbad = 0
          DO i = 1, klon
-         IF (zt(i).LT.100.0) THEN
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
             jbad = jbad + 1
             jadrs(jbad) = i
@@ -91,5 +92,6 @@
          jbad = 0
          DO i = 1, klon
-         IF (zt(i).LT.100.0) THEN
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
             jbad = jbad + 1
             jadrs(jbad) = i
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_cpl.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_cpl.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_cpl.h	(revision 300)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+! -- inc_cpl.h   1998-04
+!    **********
+!@
+!@  Contents : variables describing pipe and field names
+!@  --------
+!@
+!@ -- cl_write  : for fields to write
+!@
+!@ -- cl_read  : for fields to read
+!@
+!     -------------------------------------------------------------------
+!
+      INTEGER jpread, jpwrit
+      PARAMETER (jpread=0, jpwrit=1)
+      CHARACTER*8 cl_writ(jpmaxfld), cl_read(jpmaxfld)
+      CHARACTER*6 cl_f_writ(jpmaxfld), cl_f_read(jpmaxfld)
+      COMMON / comcpl / cl_writ, cl_read, cl_f_writ, cl_f_read
+!     -------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_sipc.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_sipc.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/inc_sipc.h	(revision 300)
@@ -0,0 +1,23 @@
+C
+C -- inc_sipc.h   97-08-11   Version 2.0   Author: S&A
+C    **********
+C@
+C@  Contents : variables describing pools formed of shared memory segments 
+C@  --------
+C@
+C@ -- mpoolinit(r/w) : handles associated to model pools for passing initial info
+C@
+C@ -- mpoolwrit : handles associated to pools used to pass fields exchanged 
+C@               from model to coupler (see libsipc/SIPC_Write_Model.f)
+C@
+C@ -- mpoolread : handles associated to pools used to pass fields exchanged
+C@               from model to coupler (see libsipc/SIPC_Read_Model.f) 
+C@ 
+C     -------------------------------------------------------------------
+C
+      INTEGER  mpoolinitr
+      INTEGER  mpoolinitw
+      INTEGER  mpoolwrit(jpmaxfld)
+      INTEGER  mpoolread(jpmaxfld)
+      COMMON / compool / mpoolinitr, mpoolinitw, mpoolwrit, mpoolread
+C     -------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/indicesol.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/indicesol.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/indicesol.h	(revision 300)
@@ -1,14 +1,17 @@
       INTEGER nbsrf
       PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
-c
+!
       INTEGER is_oce
-      PARAMETER (is_oce=1) ! ocean
+      PARAMETER (is_oce=3) ! ocean
       INTEGER is_sic
-      PARAMETER (is_sic=2) ! glace de mer
+      PARAMETER (is_sic=4) ! glace de mer
       INTEGER is_ter
-      PARAMETER (is_ter=3) ! terre
+      PARAMETER (is_ter=1) ! terre
       INTEGER is_lic
-      PARAMETER (is_lic=4) ! glacier continental
-c
+      PARAMETER (is_lic=2) ! glacier continental
+!
       REAL epsfra
       PARAMETER (epsfra=1.0E-05)
+!
+      CHARACTER *3 clnsurf(nbsrf)
+      DATA clnsurf/'ter', 'lic', 'oce', 'sic'/
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/indicesol.inc
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/indicesol.inc	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/indicesol.inc	(revision 300)
@@ -0,0 +1,9 @@
+      INTEGER, parameter :: nbsrf=4
+      INTEGER, parameter :: is_oce=3 !ocean
+      INTEGER, parameter :: is_sic = 4 ! glace de mer
+      INTEGER, parameter :: is_ter = 1 ! terre
+      INTEGER, parameter :: is_lic = 2 ! glacier continental
+      REAL,parameter :: epsfra = 1.0E-05
+!
+      CHARACTER (len=3),dimension(nbsrf) :: clnsurf(nbsrf)
+      DATA clnsurf/'ter', 'lic', 'oce', 'sic'/
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/initphysto.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/initphysto.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/initphysto.F	(revision 300)
@@ -0,0 +1,288 @@
+C
+C $Header$
+C
+      subroutine initphysto
+     .  (infile,
+     .  rlon, rlat, tstep,t_ops,t_wrt,nq,fileid)
+
+       USE IOIPSL
+
+      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   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 "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+
+C   Arguments
+      character*(*) infile
+      integer*4 nhoriid, i
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq,l
+      real nivsigs(llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan
+      logical ok_sync
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+C
+      REAL rlon(klon), rlat(klon)
+
+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 = anneeref
+      CALL ymds2ju(zan, 1, 1, 0.0, zjulian)
+      zjulian = zjulian + dayref
+      tau0 = 0
+	
+	CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjm+1) = rlon(i+1)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+
+
+      call histbeg(infile, iim, zx_lon, jjm+1, zx_lat,
+     .             1, iim, 1, jjm+1,
+     .             tau0, zjulian, tstep, nhoriid, fileid)
+
+C  Appel a histvert pour la grille verticale
+C
+	DO l=1,llm
+            nivsigs(l)=float(l)
+         ENDDO
+	
+	write(*,*) 'avant histvert ds initphysto'
+
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+	write(*,*) 'apres histvert ds initphysto'
+
+       CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iim,jjm+1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+c
+	write(*,*) 'apres phis ds initphysto'
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iim,jjm+1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         write(*,*) 'apres aire ds initphysto'
+
+         CALL histdef(fileid, "dtime", "tps phys ", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	 CALL histdef(fileid, "istphy", "tps stock", "s",
+     .                1,1,nhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+C T 
+C
+      call histdef(fileid, 't', 'Temperature', 'K',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres t ds initphysto'
+C mfu 
+C
+      call histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        write(*,*) 'apres mfu ds initphysto'
+C
+C mfd 
+C
+      call histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_u 
+C
+      call histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+               write(*,*) 'apres en_u ds initphysto'
+C
+C de_u 
+C
+      call histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C en_d 
+C
+      call histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C de_d 
+C
+      call histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c coefh frac_impa,frac_nucl
+	
+	call histdef(fileid, 'coefh', ' ', ' ',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+	
+	write(*,*) 'apres coefh ds initphysto'	
+
+	call histdef(fileid, 'frac_impa', ' ', ' ',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+	
+	call histdef(fileid, 'frac_nucl', ' ', ' ',
+     .             iim, jjm+1, nhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+c
+c pyu1
+c
+      CALL histdef(fileid, "pyu1", " ", " ",
+     .                iim,jjm+1,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+
+c
+c pyv1
+c
+	CALL histdef(fileid, "pyv1", " ", " ",
+     .                iim,jjm+1,nhoriid, 1,1,1, -99, 32,
+     .                "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'apres pyv1 ds initphysto'
+c
+c ftsol1
+c
+	call histdef(fileid, "ftsol1", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol2
+c
+        call histdef(fileid, "ftsol2", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1,1, -99,32,
+     .             "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol3
+c
+        call histdef(fileid, "ftsol3", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c ftsol4
+c
+        call histdef(fileid, "ftsol4", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c rain
+c
+        call histdef(fileid, "rain", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1,1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf1
+c
+	call histdef(fileid, "psrf1", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+c
+c psrf2
+c
+        call histdef(fileid, "psrf2", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf3
+c
+        call histdef(fileid, "psrf3", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+
+c
+c psrf4
+c
+        call histdef(fileid, "psrf4", " ", " ",
+     .             iim, jjm+1, nhoriid, 1, 1, 1, -99,
+     .             32, "inst(X)", t_ops, t_wrt)
+	
+	write(*,*) 'avant histend ds initphysto'	
+
+      call histend(fileid)
+      if (ok_sync) call histsync(fileid)
+
+	
+
+      return
+      end
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/interface_surf.F90
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/interface_surf.F90	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/interface_surf.F90	(revision 300)
@@ -0,0 +1,2607 @@
+! $Header$
+
+  MODULE interface_surf
+
+! Ce module regroupe toutes les routines gerant l'interface entre le modele 
+! atmospherique et les modeles de surface (sols continentaux, oceans, glaces)
+! Les routines sont les suivantes:
+!
+!   interfsurf_*: routines d'aiguillage vers les interfaces avec les 
+!                 differents modeles de surface
+!   interfsol\
+!             > routines d'interface proprement dite
+!   interfoce/
+!
+!   interfstart: routine d'initialisation et de lecture de l'etat initial
+!                "interface"
+!   interffin  : routine d'ecriture de l'etat de redemmarage de l'interface
+!
+! 
+! L. Fairhead, LMD, 02/2000
+
+  USE ioipsl
+
+  IMPLICIT none
+
+  PRIVATE
+  PUBLIC :: interfsurf,interfsurf_hq, gath2cpl 
+
+  INTERFACE interfsurf
+    module procedure interfsurf_hq, interfsurf_vent
+  END INTERFACE
+
+  INTERFACE interfoce
+    module procedure interfoce_cpl, interfoce_slab, interfoce_lim
+  END INTERFACE
+
+#include "YOMCST.inc"
+#include "indicesol.inc"
+
+
+! run_off      ruissellement total
+  real, allocatable, dimension(:),save    :: run_off
+  real, allocatable, dimension(:),save    :: coastalflow, riverflow
+!!$PB
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: tmp_rriv, tmp_rcoa
+!!$
+  CONTAINS
+!
+!############################################################################
+!
+  SUBROUTINE interfsurf_hq(itime, dtime, date0, jour, rmu0, &
+      & klon, iim, jjm, nisurf, knon, knindex, pctsrf, &
+      & rlon, rlat, cufi, cvfi,&
+      & debut, lafin, ok_veget, soil_model, nsoilmx, tsoil,&
+      & zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+      & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+      & precip_rain, precip_snow, sollw, sollwdown, swnet, swdown, &
+      & fder, taux, tauy, rugos, rugoro, &
+      & albedo, snow, qsol, &
+      & tsurf, p1lay, ps, radsol, &
+      & ocean, npas, nexca, zmasq, &
+      & evap, fluxsens, fluxlat, dflux_l, dflux_s, &              
+      & tsol_rad, tsurf_new, alb_new, alblw, emis_new, &
+      & z0_new, pctsrf_new, agesno)
+
+
+! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general 
+! (sols continentaux, oceans, glaces) pour les fluxs de chaleur et d'humidite.
+! En pratique l'interface se fait entre la couche limite du modele 
+! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...)
+!
+! 
+! L.Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   klon         nombre total de points de grille
+!   iim, jjm     nbres de pts de grille
+!   dtime        pas de temps de la physique (en s)
+!   date0        jour initial 
+!   jour         jour dans l'annee en cours,
+!   rmu0         cosinus de l'angle solaire zenithal
+!   nexca        pas de temps couplage
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   pctsrf       tableau des pourcentages de surface de chaque maille
+!   rlon         longitudes
+!   rlat         latitudes
+!   cufi,cvfi    resolution des mailles en x et y (m)
+!   debut        logical: 1er appel a la physique
+!   lafin        logical: dernier appel a la physique
+!   ok_veget     logical: appel ou non au schema de surface continental
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   zlev         hauteur de la premiere couche
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp potentielle de l'air
+!   ccanopy      concentration CO2 canopee
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   sollw        flux IR net a la surface
+!   sollwdown    flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   albedo       albedo de la surface
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   ocean        type d'ocean utilise (force, slab, couple)
+!   fder         derivee des flux (pour le couplage)
+!   taux, tauy   tension de vents
+!   rugos        rugosite
+!   zmasq        masque terre/ocean
+!   rugoro       rugosite orographique
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb_new      albedo
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   pctsrf_new   nouvelle repartition des surfaces
+
+
+! Parametres d'entree
+  integer, intent(IN) :: itime
+  integer, intent(IN) :: iim, jjm
+  integer, intent(IN) :: klon
+  real, intent(IN) :: dtime
+  real, intent(IN) :: date0
+  integer, intent(IN) :: jour
+  real, intent(IN)    :: rmu0(klon)
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+  integer, dimension(klon), intent(in) :: knindex
+  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
+  logical, intent(IN) :: debut, lafin, ok_veget
+  real, dimension(klon), intent(IN) :: rlon, rlat
+  real, dimension(klon), intent(IN) :: cufi, cvfi
+  real, dimension(klon), intent(INOUT) :: tq_cdrag
+  real, dimension(klon), intent(IN) :: zlev
+  real, dimension(klon), intent(IN) :: u1_lay, v1_lay
+  real, dimension(klon), intent(IN) :: temp_air, spechum
+  real, dimension(klon), intent(IN) :: epot_air, ccanopy
+  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
+  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
+  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
+  real, dimension(klon), intent(IN) :: sollw, sollwdown, swnet, swdown
+  real, dimension(klon), intent(IN) :: ps, albedo
+  real, dimension(klon), intent(IN) :: tsurf, p1lay
+  REAL, DIMENSION(klon), INTENT(INOUT) :: radsol,fder
+  real, dimension(klon), intent(IN) :: zmasq
+  real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro
+  character (len = 6)  :: ocean
+  integer              :: npas, nexca ! nombre et pas de temps couplage
+  real, dimension(klon), intent(INOUT) :: evap, snow, qsol
+!! PB ajout pour soil
+  logical          :: soil_model
+  integer          :: nsoilmx
+  REAL, DIMENSION(klon, nsoilmx) :: tsoil
+  REAL, dimension(klon)          :: soilcap
+  REAL, dimension(klon)          :: soilflux
+! Parametres de sortie
+  real, dimension(klon), intent(OUT):: fluxsens, fluxlat
+  real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new
+  real, dimension(klon), intent(OUT):: alblw
+  real, dimension(klon), intent(OUT):: emis_new, z0_new
+  real, dimension(klon), intent(OUT):: dflux_l, dflux_s
+  real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new
+  real, dimension(klon), intent(INOUT):: agesno
+
+! Local
+  character (len = 20),save :: modname = 'interfsurf_hq'
+  character (len = 80) :: abort_message 
+  logical, save        :: first_call = .true.
+  integer, save        :: error
+  integer              :: ii, index
+  logical,save              :: check = .false.
+  real, dimension(klon):: cal, beta, dif_grnd, capsol
+!!$PB  real, parameter      :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5.
+  real, parameter      :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5.
+  real, parameter      :: calsno=1./(2.3867e+06*.15)
+  real, dimension(klon):: alb_ice
+  real, dimension(klon):: tsurf_temp
+!!  real, allocatable, dimension(:), save :: alb_neig_grid
+  real, dimension(klon):: alb_neig, alb_eau
+  real, DIMENSION(klon):: zfra
+  logical              :: cumul = .false.
+
+  if (check) write(*,*) 'Entree ', modname
+!
+! On doit commencer par appeler les schemas de surfaces continentales
+! car l'ocean a besoin du ruissellement qui est y calcule
+!
+  if (first_call) then
+    if (nisurf /= is_ter .and. klon > 1) then 
+      write(*,*)' *** Warning ***'
+      write(*,*)' nisurf = ',nisurf,' /= is_ter = ',is_ter
+      write(*,*)'or on doit commencer par les surfaces continentales'
+      abort_message='voir ci-dessus'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    if (ocean /= 'slab  ' .and. ocean /= 'force ' .and. ocean /= 'couple') then
+      write(*,*)' *** Warning ***'
+      write(*,*)'Option couplage pour l''ocean = ', ocean
+      abort_message='option pour l''ocean non valable'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    if ( is_oce > is_sic ) then
+      write(*,*)' *** Warning ***'
+      write(*,*)' Pour des raisons de sequencement dans le code'
+      write(*,*)' l''ocean doit etre traite avant la banquise'
+      write(*,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      call abort_gcm(modname,abort_message,1)
+    endif
+!    allocate(alb_neig_grid(klon), stat = error)
+!    if (error /= 0) then
+!      abort_message='Pb allocation alb_neig_grid'
+!      call abort_gcm(modname,abort_message,1)
+!    endif
+  endif
+  first_call = .false.
+  
+! Initialisations diverses
+!
+!!$  cal=0.; beta=1.; dif_grnd=0.; capsol=0.
+!!$  alb_new = 0.; z0_new = 0.; alb_neig = 0.0
+!!$! PB
+!!$  tsurf_new = 0.
+
+  cal = 999999. ; beta = 999999. ; dif_grnd = 999999. ; capsol = 999999.
+  alb_new = 999999. ; z0_new = 999999. ; alb_neig = 999999.
+  tsurf_new = 999999.
+  alblw = 999999.
+! Aiguillage vers les differents schemas de surface
+
+  if (nisurf == is_ter) then
+!
+! Surface "terre" appel a l'interface avec les sols continentaux
+!
+! allocation du run-off
+    if (.not. allocated(coastalflow)) then
+      allocate(coastalflow(knon), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation coastalflow'
+        call abort_gcm(modname,abort_message,1)
+      endif
+      allocate(riverflow(knon), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation riverflow'
+        call abort_gcm(modname,abort_message,1)
+      endif
+      allocate(run_off(knon), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation run_off'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!!$PB
+      ALLOCATE (tmp_rriv(iim,jjm+1), stat=error)
+      if (error /= 0) then
+        abort_message='Pb allocation tmp_rriv'
+        call abort_gcm(modname,abort_message,1)
+      endif
+      ALLOCATE (tmp_rcoa(iim,jjm+1), stat=error)
+      if (error /= 0) then
+        abort_message='Pb allocation tmp_rcoa'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!!$
+    else if (size(coastalflow) /= knon) then
+      write(*,*)'Bizarre, le nombre de points continentaux'
+      write(*,*)'a change entre deux appels. J''arrete ...'
+      abort_message='voir ci-dessus'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    coastalflow = 0.
+    riverflow = 0.
+!
+! Calcul age de la neige
+!
+!!$ PB ATTENTION changement ordre des appels
+!!$    CALL albsno(klon,agesno,alb_neig_grid)  
+
+    if (.not. ok_veget) then
+!
+! calcul albedo: lecture albedo fichier CL puis ajout albedo neige 
+! 
+       call interfsur_lim(itime, dtime, jour, &
+     & klon, nisurf, knon, knindex, debut,  &
+     & alb_new, z0_new)
+!  
+! calcul snow et qsol, hydrol adapté
+!
+       CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd)
+
+       IF (soil_model) THEN 
+           CALL soil(dtime, nisurf, knon,snow, tsurf, tsoil,soilcap, soilflux)
+           cal(1:knon) = RCPD / soilcap(1:knon)
+           radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+       ELSE 
+           cal = RCPD * capsol
+!!$      cal = capsol
+       ENDIF
+       CALL calcul_fluxs( klon, knon, nisurf, dtime, &
+     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+     &   precip_rain, precip_snow, snow, qsol,  &
+     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+       CALL fonte_neige( klon, knon, nisurf, dtime, &
+     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+     &   precip_rain, precip_snow, snow, qsol,  &
+     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+
+     call albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+     where (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+     zfra(1:knon) = max(0.0,min(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+     alb_new(1 : knon)  = alb_neig(1 : knon) *zfra(1:knon) + &
+    &                     alb_new(1 : knon)*(1.0-zfra(1:knon))
+     z0_new = sqrt(z0_new**2+rugoro**2)
+     alblw(1 : knon) = alb_new(1 : knon)
+
+    else
+!!      CALL albsno(klon,agesno,alb_neig_grid)  
+!
+!  appel a sechiba
+!
+      call interfsol(itime, klon, dtime, date0, nisurf, knon, &
+     &  knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, &
+     &  debut, lafin, ok_veget, &
+     &  zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+     &  tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &  precip_rain, precip_snow, sollwdown, swnet, swdown, &
+     &  tsurf, p1lay/100., ps, radsol, &
+     &  evap, fluxsens, fluxlat, &              
+     &  tsol_rad, tsurf_new, alb_new, alblw, &
+     &  emis_new, z0_new, dflux_l, dflux_s)
+
+!  
+! ajout de la contribution du relief
+!  
+      z0_new = SQRT(z0_new**2+rugoro**2)
+
+    endif    
+!
+! Remplissage des pourcentages de surface
+!
+    pctsrf_new(:,nisurf) = pctsrf(:,nisurf)
+
+  else if (nisurf == is_oce) then
+
+    if (check) write(*,*)'ocean, nisurf = ',nisurf 
+
+
+!
+! Surface "ocean" appel a l'interface avec l'ocean
+!
+    if (ocean == 'couple') then
+      if (nexca == 0) then
+        abort_message='nexca = 0 dans interfoce_cpl'
+        call abort_gcm(modname,abort_message,1)
+      endif
+
+      cumul = .false.
+
+      call interfoce(itime, dtime, cumul, &
+      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
+      & ocean, npas, nexca, debut, lafin, &
+      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
+      & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, &
+      & tsurf_new, alb_new, pctsrf_new)
+
+!    else if (ocean == 'slab  ') then
+!      call interfoce(nisurf)
+    else                              ! lecture conditions limites
+      call interfoce(itime, dtime, jour, & 
+     &  klon, nisurf, knon, knindex, &
+     &  debut, &
+     &  tsurf_new, pctsrf_new)
+
+    endif
+
+    tsurf_temp = tsurf_new
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+
+    call calcul_fluxs( klon, knon, nisurf, dtime, &
+     &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+     &   precip_rain, precip_snow, snow, qsol,  &
+     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    fder = fder + dflux_s + dflux_l
+
+!
+! 2eme appel a interfoce pour le cumul des champs (en particulier
+! fluxsens et fluxlat calcules dans calcul_fluxs)
+!
+    if (ocean == 'couple') then
+
+      cumul = .true.
+
+      call interfoce(itime, dtime, cumul, &
+      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
+      & ocean, npas, nexca, debut, lafin, &
+      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
+      & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, &
+      & tsurf_new, alb_new, pctsrf_new)
+
+!    else if (ocean == 'slab  ') then
+!      call interfoce(nisurf)
+
+    endif
+
+!
+! calcul albedo
+!
+
+    if ( minval(rmu0) == maxval(rmu0) .and. minval(rmu0) == -999.999 ) then
+      CALL alboc(FLOAT(jour),rlat,alb_eau)
+    else  ! cycle diurne
+      CALL alboc_cd(rmu0,alb_eau)
+    endif
+    DO ii =1, knon
+      alb_new(ii) = alb_eau(knindex(ii))
+    enddo
+
+    z0_new = sqrt(rugos**2 + rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+
+!
+  else if (nisurf == is_sic) then
+
+    if (check) write(*,*)'sea ice, nisurf = ',nisurf 
+
+!
+! Surface "glace de mer" appel a l'interface avec l'ocean
+!
+!
+    if (ocean == 'couple') then
+
+      cumul =.false.
+
+      call interfoce(itime, dtime, cumul, &
+      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
+      & ocean, npas, nexca, debut, lafin, &
+      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
+      & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, &
+      & tsurf_new, alb_new, pctsrf_new)
+
+      tsurf_temp = tsurf_new
+      cal = 0.
+      dif_grnd = 0.
+      beta = 1.0
+
+!    else if (ocean == 'slab  ') then
+!      call interfoce(nisurf)
+    ELSE
+!                              ! lecture conditions limites
+      CALL interfoce(itime, dtime, jour, & 
+             &  klon, nisurf, knon, knindex, &
+             &  debut, &
+             &  tsurf_new, pctsrf_new)
+
+      CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd)
+      
+      IF (soil_model) THEN 
+         CALL soil(dtime, nisurf, knon,snow, tsurf, tsoil,soilcap, soilflux)
+         cal(1:knon) = RCPD / soilcap(1:knon)
+         radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+         dif_grnd = 0.
+      ELSE 
+         dif_grnd = 1.0 / tau_gl
+         cal = RCPD * calice
+         WHERE (snow > 0.0) cal = RCPD * calsno 
+      ENDIF
+      tsurf_temp = tsurf
+      beta = 1.0
+    ENDIF
+
+    CALL calcul_fluxs( klon, knon, nisurf, dtime, &
+         &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+         &   precip_rain, precip_snow, snow, qsol,  &
+         &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    IF (ocean /= 'couple') THEN
+      CALL fonte_neige( klon, knon, nisurf, dtime, &
+             &   tsurf_temp, p1lay, cal, beta, tq_cdrag, ps, &
+             &   precip_rain, precip_snow, snow, qsol,  &
+             &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+             &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+             &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!     calcul albedo
+
+      CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+      WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+      zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+      alb_new(1 : knon) = alb_neig(1 : knon) *zfra(1:knon) + & 
+     &                    0.6 * (1.0-zfra(1:knon))
+!!      alb_new(1 : knon) = 0.6
+    ENDIF
+
+    fder = fder + dflux_s + dflux_l
+
+!
+! 2eme appel a interfoce pour le cumul et le passage des flux a l'ocean
+!
+    if (ocean == 'couple') then
+
+      cumul =.true.
+
+      call interfoce(itime, dtime, cumul, &
+      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
+      & ocean, npas, nexca, debut, lafin, &
+      & swdown, sollw, precip_rain, precip_snow, evap, tsurf, &
+      & fluxlat, fluxsens, fder, albedo, taux, tauy, zmasq, &
+      & tsurf_new, alb_new, pctsrf_new)
+
+!    else if (ocean == 'slab  ') then
+!      call interfoce(nisurf)
+
+    endif
+
+     
+    z0_new = 0.001
+    z0_new = SQRT(z0_new**2+rugoro**2)
+    alblw(1:knon) = alb_new(1:knon)
+
+  else if (nisurf == is_lic) then
+
+    if (check) write(*,*)'glacier, nisurf = ',nisurf 
+
+!
+! Surface "glacier continentaux" appel a l'interface avec le sol
+!
+!    call interfsol(nisurf)
+    IF (soil_model) THEN 
+        CALL soil(dtime, nisurf, knon, snow, tsurf, tsoil,soilcap, soilflux)
+        cal(1:knon) = RCPD / soilcap(1:knon)
+        radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
+    ELSE 
+        cal = RCPD * calice
+        WHERE (snow > 0.0) cal = RCPD * calsno
+    ENDIF 
+    beta = 1.0
+    dif_grnd = 0.0
+
+    call calcul_fluxs( klon, knon, nisurf, dtime, &
+     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+     &   precip_rain, precip_snow, snow, qsol,  &
+     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    call fonte_neige( klon, knon, nisurf, dtime, &
+     &   tsurf, p1lay, cal, beta, tq_cdrag, ps, &
+     &   precip_rain, precip_snow, snow, qsol,  &
+     &   radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+     &   petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     &   tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+!
+! calcul albedo
+!
+     CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+     WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+     zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+     alb_new(1 : knon)  = alb_neig(1 : knon)*zfra(1:knon) + &
+    &                     0.6 * (1.0-zfra(1:knon))
+!!     alb_new(1 : knon)  = 0.6
+!
+! Rugosite
+!
+    z0_new = rugoro
+!
+! Remplissage des pourcentages de surface
+!
+    pctsrf_new(:,nisurf) = pctsrf(:,nisurf)
+
+    alblw(1:knon) = alb_new(1:knon)
+  else
+    write(*,*)'Index surface = ',nisurf
+    abort_message = 'Index surface non valable'
+    call abort_gcm(modname,abort_message,1)
+  endif
+
+  END SUBROUTINE interfsurf_hq
+
+!
+!#########################################################################
+!
+  SUBROUTINE interfsurf_vent(nisurf, knon   &         
+  &                     )
+!
+! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general 
+! (sols continentaux, oceans, glaces) pour les tensions de vents.
+! En pratique l'interface se fait entre la couche limite du modele 
+! atmospherique (clmain.F) et les routines de surface (sechiba, oasis, ...)
+!
+! 
+! L.Fairhead 02/2000
+!
+! input:
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+
+! Parametres d'entree
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+
+
+  return
+  END SUBROUTINE interfsurf_vent
+!
+!#########################################################################
+!
+  SUBROUTINE interfsol(itime, klon, dtime, date0, nisurf, knon, &
+     & knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, &
+     & debut, lafin, ok_veget, &
+     & zlev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+     & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     & precip_rain, precip_snow, lwdown, swnet, swdown, &
+     & tsurf, p1lay, ps, radsol, &
+     & evap, fluxsens, fluxlat, &              
+     & tsol_rad, tsurf_new, alb_new, alblw, &
+     & emis_new, z0_new, dflux_l, dflux_s)
+
+  USE intersurf
+
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   klon         nombre total de points de grille
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!   ok_veget     logical: appel ou non au schema de surface continental
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   zlev         hauteur de la premiere couche       
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! input/output
+!   run_off      ruissellement total
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb_new      albedo
+!   emis_new     emissivite
+!   z0_new       surface roughness
+
+
+! Parametres d'entree
+  integer, intent(IN) :: itime
+  integer, intent(IN) :: klon
+  real, intent(IN)    :: dtime
+  real, intent(IN)    :: date0
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+  integer, intent(IN) :: iim, jjm
+  integer, dimension(klon), intent(IN) :: knindex
+  logical, intent(IN) :: debut, lafin, ok_veget
+  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
+  real, dimension(klon), intent(IN) :: rlon, rlat
+  real, dimension(klon), intent(IN) :: cufi, cvfi
+  real, dimension(klon), intent(IN) :: zlev
+  real, dimension(klon), intent(IN) :: u1_lay, v1_lay
+  real, dimension(klon), intent(IN) :: temp_air, spechum
+  real, dimension(klon), intent(IN) :: epot_air, ccanopy
+  real, dimension(klon), intent(INOUT) :: tq_cdrag
+  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
+  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
+  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
+  real, dimension(klon), intent(IN) :: lwdown, swnet, swdown, ps
+  real, dimension(klon), intent(IN) :: tsurf, p1lay
+  real, dimension(klon), intent(IN) :: radsol
+! Parametres de sortie
+  real, dimension(klon), intent(OUT):: evap, fluxsens, fluxlat
+  real, dimension(klon), intent(OUT):: tsol_rad, tsurf_new, alb_new, alblw
+  real, dimension(klon), intent(OUT):: emis_new, z0_new
+  real, dimension(klon), intent(OUT):: dflux_s, dflux_l
+
+! Local
+!
+  integer              :: ii, ij, jj, igrid, ireal, i, index, iglob
+  integer              :: error
+  character (len = 20) :: modname = 'interfsol'
+  character (len = 80) :: abort_message
+  logical,save              :: check = .FALSE.
+  real, dimension(klon) :: cal, beta, dif_grnd, capsol
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! coordonnees geographiques
+  real, allocatable, dimension(:,:), save :: lalo
+! pts voisins
+  integer,allocatable, dimension(:,:), save :: neighbours
+! fractions continents
+  real,allocatable, dimension(:), save :: contfrac
+! resolution de la grille
+  real, allocatable, dimension (:,:), save :: resolution
+! correspondance point n -> indices (i,j)
+  integer, allocatable, dimension(:,:), save :: correspond
+! offset pour calculer les point voisins
+  integer, dimension(8,3), save :: off_ini
+  integer, dimension(8), save :: offset
+! Identifieurs des fichiers restart et histoire
+  integer, save          :: rest_id, hist_id 
+  integer, save          :: rest_id_stom, hist_id_stom
+! 
+  real, allocatable, dimension (:,:), save :: lon_scat, lat_scat  
+
+  logical, save          :: lrestart_read = .true. , lrestart_write = .false.
+
+  real, dimension(klon):: qsurf
+  real, dimension(klon):: snow, qsol
+  real, dimension(knon,2) :: albedo_out
+! Pb de nomenclature
+  real, dimension(klon) :: petA_orc, peqA_orc
+  real, dimension(klon) :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+  integer, dimension(:), save, allocatable :: ig, jg
+  integer :: indi, indj
+  integer, dimension(klon) :: ktindex
+  REAL, dimension(klon) :: bidule
+! Essai cdrag
+  real, dimension(klon) :: cdrag
+
+  if (check) write(*,*)'Entree ', modname
+  if (check) write(*,*)'ok_veget = ',ok_veget
+
+  ktindex(:) = knindex(:) + iim - 1
+
+! initialisation
+  if (debut) then
+
+! Pb de correspondances de grilles
+   allocate(ig(klon))
+   allocate(jg(klon))
+   ig(1) = 1
+   jg(1) = 1
+   indi = 0
+   indj = 2
+   do igrid = 2, klon - 1
+     indi = indi + 1
+     if ( indi > iim) then
+       indi = 1
+       indj = indj + 1
+     endif
+     ig(igrid) = indi
+     jg(igrid) = indj
+   enddo
+   ig(klon) = 1
+   jg(klon) = jjm + 1
+!
+!  Initialisation des offset    
+!
+! offset bord ouest
+   off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
+   off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
+   off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
+! offset point normal
+   off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
+   off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
+   off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
+! offset bord   est
+   off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
+   off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
+   off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
+!
+! Initialisation des correspondances point -> indices i,j
+!
+    if (( .not. allocated(correspond))) then
+      allocate(correspond(iim,jjm+1), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation correspond'
+        call abort_gcm(modname,abort_message,1)
+      endif      
+    endif
+!
+! Attention aux poles
+!
+!!$    do igrid = 1, knon
+!!$      index = ktindex(igrid)
+!!$      ij = index - int((index-1)/iim)*iim - 1
+!!$      jj = 2 + int((index-1)/iim)
+!!$      if (mod(index,iim) == 1 ) then
+!!$        jj = 1 + int((index-1)/iim)
+!!$        ij = iim
+!!$      endif
+!!$      correspond(ij,jj) = igrid
+!!$      write(50,*)'igrid, i, j =',igrid,ij,jj
+!!$    enddo
+! Pb de correspondances de grilles!
+!!$    do igrid = 1, knon
+!!$      index = ktindex(igrid)
+!!$      ij = ig(index)
+!!$      jj = jg(index)
+!!$      correspond(ij,jj) = igrid
+!!$      write(51,*)'igrid, i, j =',igrid,ij,jj
+!!$    enddo
+    do igrid = 1, knon
+      index = ktindex(igrid)
+          jj = int((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+      correspond(ij,jj) = igrid
+    enddo
+
+!!$    index = 0
+!!$    do jj = 1, jjm+1
+!!$      do ij = 1, iim
+!!$        index = index + 1
+!!$        correspond(ij,jj) = index
+!!$      enddo
+!!$    enddo
+
+! Allouer et initialiser le tableau de coordonnees du sol
+!
+    if ((.not. allocated(lalo))) then
+      allocate(lalo(knon,2), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation lalo'
+        call abort_gcm(modname,abort_message,1)
+      endif      
+    endif
+    if ((.not. allocated(lon_scat))) then
+      allocate(lon_scat(iim,jjm+1), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation lon_scat'
+        call abort_gcm(modname,abort_message,1)
+      endif      
+    endif
+    if ((.not. allocated(lat_scat))) then
+      allocate(lat_scat(iim,jjm+1), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation lat_scat'
+        call abort_gcm(modname,abort_message,1)
+      endif      
+    endif
+    lon_scat = 0.
+    lat_scat = 0.
+    do igrid = 1, knon
+      index = knindex(igrid)
+      lalo(igrid,2) = rlon(index)
+      lalo(igrid,1) = rlat(index)
+      ij = index - int((index-1)/iim)*iim - 1
+      jj = 2 + int((index-1)/iim)
+      if (mod(index,iim) == 1 ) then
+        jj = 1 + int((index-1)/iim)
+        ij = iim
+      endif
+!      lon_scat(ij,jj) = rlon(index)
+!      lat_scat(ij,jj) = rlat(index)
+    enddo
+    index = 1
+    do jj = 2, jjm
+      do ij = 1, iim
+        index = index + 1
+        lon_scat(ij,jj) = rlon(index)
+        lat_scat(ij,jj) = rlat(index)
+      enddo
+    enddo
+    lon_scat(:,1) = lon_scat(:,2)
+    lat_scat(:,1) = rlat(1)
+    lon_scat(:,jjm+1) = lon_scat(:,2)
+    lat_scat(:,jjm+1) = rlat(klon)
+! Pb de correspondances de grilles!
+!    do igrid = 1, knon
+!      index = ktindex(igrid)
+!      ij = ig(index)
+!      jj = jg(index)
+!      lon_scat(ij,jj) = rlon(index)
+!      lat_scat(ij,jj) = rlat(index)
+!    enddo
+
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+    if ( (.not.allocated(neighbours))) THEN
+      allocate(neighbours(knon,8), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation neighbours'
+        call abort_gcm(modname,abort_message,1)
+      endif
+    endif
+    neighbours = -1.
+    if (( .not. allocated(contfrac))) then
+      allocate(contfrac(knon), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation contfrac'
+        call abort_gcm(modname,abort_message,1)
+      endif      
+    endif
+
+    do igrid = 1, knon
+      ireal = knindex(igrid)
+      contfrac(igrid) = pctsrf(ireal,is_ter)
+    enddo
+
+    do igrid = 1, knon
+      iglob = ktindex(igrid)
+      if (mod(iglob, iim) == 1) then
+        offset = off_ini(:,1)
+      else if(mod(iglob, iim) == 0) then
+        offset = off_ini(:,3)
+      else
+        offset = off_ini(:,2)
+      endif 
+      do i = 1, 8
+        index = iglob + offset(i)
+        ireal = (min(max(1, index - iim + 1), klon))
+!        if (index <= 1) index = 1
+!        if (index >= klon) index = klon
+        if (pctsrf(ireal, is_ter) > EPSFRA) then
+          jj = int((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+!!$          ij = index - int((index-1)/iim)*iim - 1
+!!$          jj = 2 + int((index-1)/iim)
+!!$          if (mod(index,iim) == 1 ) then
+!!$            jj = 1 + int((index-1)/iim)
+!!$            ij = iim
+!!$          endif
+!!$! Pb de correspondances de grilles!
+!!$      ij = ig(index)
+!!$      jj = jg(index)
+!!$!          write(*,*)'correspond',igrid, ireal,index,ij,jj
+!          if ( ij >= 1 .and. ij <= iim .and. jj >= 1 .and. jj <= jjm) then
+!          write(*,*)'correspond',igrid, ireal,index,ij,jj
+            neighbours(igrid, i) = correspond(ij, jj)
+!          endif
+        endif
+      enddo
+    enddo
+
+    write(*,*)'Neighbours = '
+
+    write(*,*)neighbours(1,8), neighbours(1,1),neighbours(1,2)
+    write(*,*)neighbours(1,7), ktindex(1), neighbours(1,3)
+    write(*,*)neighbours(1,6), neighbours(1,5),neighbours(1,4)
+
+    write(*,*)neighbours(250,8), neighbours(250,1),neighbours(250,2)
+    write(*,*)neighbours(250,7), ktindex(250), neighbours(250,3)
+    write(*,*)neighbours(250,6), neighbours(250,5),neighbours(250,4)
+
+ OPEN (unit=12, file="neighbours.9671")
+  DO i=1,knon
+     WRITE(12,*) '-----------------------------'
+     WRITE(12,'(I7,f8.5,   "    ",3I6)') knon, contfrac(i), &
+          & neighbours(i,8), neighbours(i,1), neighbours(i,2)
+     WRITE(12,'(f10.5,"         ",3I6)') lalo(i,2), neighbours(i,7), &
+          & ktindex(i), neighbours(i,3)
+     WRITE(12,'(f10.5,"         ",3I6)') lalo(i,1), neighbours(i,6), &
+          & neighbours(i,5), neighbours(i,3)
+  ENDDO
+  CLOSE(12)
+
+
+!
+!  Allocation et calcul resolutions
+    IF ( (.NOT.ALLOCATED(resolution))) THEN
+      ALLOCATE(resolution(knon,2), stat = error)
+      if (error /= 0) then
+        abort_message='Pb allocation resolution'
+        call abort_gcm(modname,abort_message,1)
+      endif
+    ENDIF
+    do igrid = 1, knon
+      ij = knindex(igrid)
+      resolution(igrid,1) = cufi(ij)
+      resolution(igrid,2) = cvfi(ij)
+    enddo  
+
+  endif                          ! (fin debut) 
+
+! 
+! Appel a la routine sols continentaux
+!
+  if (lafin) lrestart_write = .true.
+  if (check) write(*,*)'lafin ',lafin,lrestart_write
+
+  petA_orc = petBcoef * dtime
+  petB_orc = petAcoef
+  peqA_orc = peqBcoef * dtime
+  peqB_orc = peqAcoef
+
+  cdrag = 0.
+  cdrag(1:knon) = tq_cdrag(1:knon)
+
+   where(cdrag > 0.01) 
+     cdrag = 0.01
+   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+!
+! Init Orchidee
+!
+  if (debut) then
+    call intersurf_main (itime-1, iim, jjm+1, knon, ktindex, dtime, &
+     & lrestart_read, lrestart_write, lalo, &
+     & contfrac, neighbours, resolution, date0, &
+     & zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+     & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+     & precip_rain, precip_snow, lwdown, swnet, swdown, p1lay, &
+     & evap, fluxsens, fluxlat, coastalflow, riverflow, &
+     & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+     & lon_scat, lat_scat)
+  endif
+
+  call intersurf_main (itime, iim, jjm+1, knon, ktindex, dtime, &
+     & lrestart_read, lrestart_write, lalo, &
+     & contfrac, neighbours, resolution, date0, &
+     & zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+     & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+     & precip_rain, precip_snow, lwdown, swnet, swdown, p1lay, &
+     & evap, fluxsens, fluxlat, coastalflow, riverflow, &
+     & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+     & lon_scat, lat_scat)
+
+    bidule=0.
+    bidule(1:knon)=riverflow(1:knon)
+    call gath2cpl(bidule, tmp_rriv, klon, knon,iim,jjm,                  ktindex)
+    bidule=0.
+    bidule(1:knon)=coastalflow(1:knon)
+    call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jjm,                  ktindex)
+    alb_new(1:knon) = albedo_out(1:knon,1) 
+    alblw(1:knon) = albedo_out(1:knon,2)
+
+
+! Convention orchidee: positif vers le haut
+  fluxsens(1:knon) = -1. * fluxsens(1:knon)
+  fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+
+!  evap     = -1. * evap
+
+  if (debut) lrestart_read = .false.
+
+  END SUBROUTINE interfsol
+!
+!#########################################################################
+!
+  SUBROUTINE interfoce_cpl(itime, dtime, cumul, &
+      & klon, iim, jjm, nisurf, pctsrf, knon, knindex, rlon, rlat, &
+      & ocean, npas, nexca, debut, lafin, &
+      & swdown, lwdown, precip_rain, precip_snow, evap, tsurf, &
+      & fluxlat, fluxsens, fder, albsol, taux, tauy, zmasq, &
+      & tsurf_new, alb_new, pctsrf_new)
+
+! Cette routine sert d'interface entre le modele atmospherique et un 
+! coupleur avec un modele d'ocean 'complet' derriere
+!
+! Le modele de glace qu'il est prevu d'utiliser etant couple directement a 
+! l'ocean presentement, on va passer deux fois dans cette routine par pas de 
+! temps physique, une fois avec les points oceans et l'autre avec les points
+! glace. A chaque pas de temps de couplage, la lecture des champs provenant
+! du coupleur se fera "dans" l'ocean et l'ecriture des champs a envoyer
+! au coupleur "dans" la glace. Il faut donc des tableaux de travail "tampons"
+! dimensionnes sur toute la grille qui remplissent les champs sur les
+! domaines ocean/glace quand il le faut. Il est aussi necessaire que l'index
+! ocean soit traiter avant l'index glace (sinon tout intervertir)
+!
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   iim, jjm     nbres de pts de grille
+!   dtime        pas de tempsde la physique
+!   klon         nombre total de points de grille
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes
+!   rlat         latitudes
+!   debut        logical: 1er appel a la physique
+!   lafin        logical: dernier appel a la physique
+!   ocean        type d'ocean
+!   nexca        frequence de couplage
+!   swdown       flux solaire entrant a la surface
+!   lwdown       flux IR net a la surface
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   evap         evaporation
+!   tsurf        temperature de surface
+!   fder         derivee dF/dT
+!   albsol       albedo du sol (coherent avec swdown)
+!   taux         tension de vent en x
+!   tauy         tension de vent en y
+!   nexca        frequence de couplage
+!   zmasq        masque terre/ocean
+!
+!
+! output:
+!   tsurf_new    temperature au sol
+!   alb_new      albedo
+!   pctsrf_new   nouvelle repartition des surfaces
+!   alb_ice      albedo de la glace
+!
+
+
+! Parametres d'entree
+  integer, intent(IN) :: itime
+  integer, intent(IN) :: iim, jjm
+  real, intent(IN) :: dtime
+  integer, intent(IN) :: klon
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+  real, dimension(klon,nbsrf), intent(IN) :: pctsrf
+  integer, dimension(klon), intent(in) :: knindex
+  logical, intent(IN) :: debut, lafin
+  real, dimension(klon), intent(IN) :: rlon, rlat
+  character (len = 6)  :: ocean
+  real, dimension(klon), intent(IN) :: lwdown, swdown
+  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
+  real, dimension(klon), intent(IN) :: tsurf, fder, albsol, taux, tauy
+  INTEGER              :: nexca, npas, kstep
+  real, dimension(klon), intent(IN) :: zmasq
+  real, dimension(klon), intent(IN) :: fluxlat, fluxsens
+  logical, intent(IN)               :: cumul
+  real, dimension(klon), intent(INOUT) :: evap
+
+! Parametres de sortie
+  real, dimension(klon), intent(OUT):: tsurf_new, alb_new
+  real, dimension(klon,nbsrf), intent(OUT) :: pctsrf_new
+
+! Variables locales
+  integer                    :: j, error, sum_error, ig, cpl_index,i
+  character (len = 20) :: modname = 'interfoce_cpl'
+  character (len = 80) :: abort_message
+  logical,save              :: check = .FALSE.
+! variables pour moyenner les variables de couplage
+  real, allocatable, dimension(:,:),save :: cpl_sols, cpl_nsol, cpl_rain
+  real, allocatable, dimension(:,:),save :: cpl_snow, cpl_evap, cpl_tsol
+  real, allocatable, dimension(:,:),save :: cpl_fder, cpl_albe, cpl_taux
+!!$PB  real, allocatable, dimension(:,:),save :: cpl_tauy, cpl_rriv, cpl_rcoa
+  real, allocatable, dimension(:,:),save :: cpl_tauy
+  real, allocatable, dimension(:,:),save :: cpl_rriv, cpl_rcoa
+!!$
+! variables tampons avant le passage au coupleur
+  real, allocatable, dimension(:,:,:),save :: tmp_sols, tmp_nsol, tmp_rain
+  real, allocatable, dimension(:,:,:),save :: tmp_snow, tmp_evap, tmp_tsol
+  real, allocatable, dimension(:,:,:),save :: tmp_fder, tmp_albe, tmp_taux
+!!$  real, allocatable, dimension(:,:,:),save :: tmp_tauy, tmp_rriv, tmp_rcoa
+  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: tmp_tauy
+! variables a passer au coupleur
+  real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 
+  real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice
+  REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv
+  REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy
+  REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz
+  REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat
+! variables relues par le coupleur
+! read_sic = fraction de glace
+! read_sit = temperature de glace
+  real, allocatable, dimension(:,:),save :: read_sst, read_sic, read_sit
+  real, allocatable, dimension(:,:),save :: read_alb_sic
+! variable tampon
+  real, dimension(klon)       :: tamp_sic
+! sauvegarde des fractions de surface d'un pas de temps a l'autre apres 
+! l'avoir lu
+  real, allocatable,dimension(:,:),save :: pctsrf_sav
+  real, dimension(iim, jjm+1, 2) :: tamp_srf
+  integer, allocatable, dimension(:), save :: tamp_ind
+  real, allocatable, dimension(:,:),save :: tamp_zmasq
+  real, dimension(iim, jjm+1) :: deno
+  integer                     :: idtime
+  integer, allocatable,dimension(:),save :: unity
+! 
+  logical, save    :: first_appel = .true.
+  logical,save          :: print
+!maf
+! variables pour avoir une sortie IOIPSL des champs echanges
+  CHARACTER*80,SAVE :: clintocplnam, clfromcplnam
+  INTEGER, SAVE :: jf,nhoridct,nidct
+  INTEGER, SAVE :: nhoridcs,nidcs
+  INTEGER :: ndexct(iim*(jjm+1)),ndexcs(iim*(jjm+1))
+  REAL :: zx_lon(iim,jjm+1), zx_lat(iim,jjm+1), zjulian
+  include 'param_cou.h'
+  include 'inc_cpl.h'
+  include 'temps.h'
+!
+! Initialisation
+!
+  if (check) write(*,*)'Entree ',modname,'nisurf = ',nisurf
+ 
+  if (first_appel) then
+    error = 0
+    allocate(unity(klon), stat = error)
+    if ( error  /=0) then
+      abort_message='Pb allocation variable unity'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    allocate(pctsrf_sav(klon,nbsrf), stat = error)
+    if ( error  /=0) then
+      abort_message='Pb allocation variable pctsrf_sav'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    pctsrf_sav = 0.
+
+    do ig = 1, klon
+      unity(ig) = ig
+    enddo
+    sum_error = 0
+    allocate(cpl_sols(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_nsol(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_rain(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_snow(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_evap(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_tsol(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_fder(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_albe(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_taux(klon,2), stat = error); sum_error = sum_error + error
+    allocate(cpl_tauy(klon,2), stat = error); sum_error = sum_error + error
+!!$PB
+!!$    allocate(cpl_rcoa(klon,2), stat = error); sum_error = sum_error + error
+!!$    allocate(cpl_rriv(klon,2), stat = error); sum_error = sum_error + error
+    ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error
+!!
+    allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error
+    allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error
+    allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error
+    allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error
+
+    if (sum_error /= 0) then
+      abort_message='Pb allocation variables couplees'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.
+    cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.
+    cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.
+
+    sum_error = 0
+    allocate(tamp_ind(klon), stat = error); sum_error = sum_error + error
+    allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error    
+    do ig = 1, klon
+      tamp_ind(ig) = ig
+    enddo
+    call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jjm, tamp_ind)
+!
+! initialisation couplage
+!
+    idtime = int(dtime)
+    call inicma(npas , nexca, idtime,(jjm+1)*iim)
+
+!
+! initialisation sorties netcdf
+!
+    CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+    zjulian = zjulian + day_ini
+    CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+    DO i = 1, iim
+      zx_lon(i,1) = rlon(i+1)
+      zx_lon(i,jjm+1) = rlon(i+1)
+    ENDDO
+    CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+    clintocplnam="cpl_atm_tauflx"
+    CALL histbeg(clintocplnam, iim,zx_lon,jjm+1,zx_lat,1,iim,1,jjm+1, &
+       & 0,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+    CALL histdef(nidct, 'tauxe','tauxe', &
+         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    CALL histdef(nidct, 'tauyn','tauyn', &
+         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    DO jf=1,jpflda2o1 + jpflda2o2
+      CALL histdef(nidct, cl_writ(jf),cl_writ(jf), &
+         & "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    END DO
+    CALL histend(nidct)
+    CALL histsync(nidct)
+
+    clfromcplnam="cpl_atm_sst"
+    CALL histbeg(clfromcplnam, iim,zx_lon,jjm+1,zx_lat,1,iim,1,jjm+1, &
+       & 0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+    DO jf=1,jpfldo2a
+      CALL histdef(nidcs, cl_read(jf),cl_read(jf), &
+         & "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+    END DO
+    CALL histend(nidcs)
+    CALL histsync(nidcs)
+
+    first_appel = .false.
+  endif ! fin if (first_appel)
+
+! Initialisations
+
+! calcul des fluxs a passer
+
+  cpl_index = 1
+  if (nisurf == is_sic) cpl_index = 2
+  if (cumul) then
+    if (check) write(*,*) modname, 'cumul des champs'
+    do ig = 1, knon
+      cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) &
+       &                          + swdown(ig)      / FLOAT(nexca)
+      cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) &
+       &                          + (lwdown(ig) + fluxlat(ig) +fluxsens(ig))&
+       &                                / FLOAT(nexca)
+      cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) &
+       &                          + precip_rain(ig) / FLOAT(nexca)
+      cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) &
+       &                          + precip_snow(ig) / FLOAT(nexca)
+      cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) &
+       &                          + evap(ig)        / FLOAT(nexca)
+      cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) &
+       &                          + tsurf(ig)       / FLOAT(nexca)
+      cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) &
+       &                          + fder(ig)        / FLOAT(nexca)
+      cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) &
+       &                          + albsol(ig)      / FLOAT(nexca)
+      cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) &
+       &                          + taux(ig)        / FLOAT(nexca)
+      cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) &
+       &                          + tauy(ig)        / FLOAT(nexca)
+!!$      cpl_rriv(ig,cpl_index) = cpl_rriv(ig,cpl_index) &
+!!$       &                          + riverflow(ig)   / FLOAT(nexca)/dtime
+!!$      cpl_rcoa(ig,cpl_index) = cpl_rcoa(ig,cpl_index) &
+!!$       &                          + coastalflow(ig) / FLOAT(nexca)/dtime
+    enddo
+    IF (cpl_index .EQ. 1) THEN 
+        cpl_rriv(:,:) = cpl_rriv(:,:) + tmp_rriv(:,:) / FLOAT(nexca)
+        cpl_rcoa(:,:) = cpl_rcoa(:,:) + tmp_rcoa(:,:) / FLOAT(nexca)
+    ENDIF
+  endif
+
+  if (mod(itime, nexca) == 1) then
+!
+! Demande des champs au coupleur
+!
+! Si le domaine considere est l'ocean, on lit les champs venant du coupleur
+!
+    if (nisurf == is_oce .and. .not. cumul) then
+      if (check) write(*,*)'rentree fromcpl, itime-1 = ',itime-1
+      call fromcpl(itime-1,(jjm+1)*iim,                                  &
+     &        read_sst, read_sic, read_sit, read_alb_sic)
+!
+! sorties NETCDF des champs recus
+!
+      ndexcs(:)=0
+      CALL histwrite(nidcs,cl_read(1),itime,read_sst,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(2),itime,read_sic,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(3),itime,read_alb_sic,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(4),itime,read_sit,iim*(jjm+1),ndexcs)
+      CALL histsync(nidcs)
+! pas utile      IF (npas-itime.LT.nexca )CALL histclo(nidcs)
+
+      do j = 1, jjm + 1
+        do ig = 1, iim
+          if (abs(1. - read_sic(ig,j)) < 0.00001) then
+            read_sst(ig,j) = RTT - 1.8
+            read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+            read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          else if (abs(read_sic(ig,j)) < 0.00001) then
+            read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+            read_sit(ig,j) = read_sst(ig,j)
+            read_alb_sic(ig,j) =  0.6
+          else
+            read_sst(ig,j) = read_sst(ig,j) / (1. - read_sic(ig,j))
+            read_sit(ig,j) = read_sit(ig,j) / read_sic(ig,j)
+            read_alb_sic(ig,j) = read_alb_sic(ig,j) / read_sic(ig,j)
+          endif
+        enddo
+      enddo
+!
+! transformer read_sic en pctsrf_sav
+!
+      call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jjm, unity)
+      do ig = 1, klon
+        IF (pctsrf(ig,is_oce) > epsfra .OR.            &
+     &             pctsrf(ig,is_sic) > epsfra) THEN
+          pctsrf_sav(ig,is_sic) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+     &                               * tamp_sic(ig)
+          pctsrf_sav(ig,is_oce) = (pctsrf(ig,is_oce) + pctsrf(ig,is_sic)) &
+     &                        - pctsrf_sav(ig,is_sic)
+        endif
+      enddo
+!
+! Pour rattraper des erreurs d'arrondis
+!
+      where (abs(pctsrf_sav(:,is_sic)) .le. 2.*epsilon(pctsrf_sav(1,is_sic)))
+        pctsrf_sav(:,is_sic) = 0.
+        pctsrf_sav(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+      endwhere
+      where (abs(pctsrf_sav(:,is_oce)) .le. 2.*epsilon(pctsrf_sav(1,is_oce)))
+        pctsrf_sav(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+        pctsrf_sav(:,is_oce) = 0.
+      endwhere
+      if (minval(pctsrf_sav(:,is_oce)) < 0.) then
+        write(*,*)'Pb fraction ocean inferieure a 0'
+        write(*,*)'au point ',minloc(pctsrf_sav(:,is_oce))
+        write(*,*)'valeur = ',minval(pctsrf_sav(:,is_oce)) 
+        abort_message = 'voir ci-dessus'
+        call abort_gcm(modname,abort_message,1)
+      endif
+      if (minval(pctsrf_sav(:,is_sic)) < 0.) then
+        write(*,*)'Pb fraction glace inferieure a 0'
+        write(*,*)'au point ',minloc(pctsrf_sav(:,is_sic))
+        write(*,*)'valeur = ',minval(pctsrf_sav(:,is_sic)) 
+        abort_message = 'voir ci-dessus'
+        call abort_gcm(modname,abort_message,1)
+      endif
+    endif 
+  endif                         ! fin mod(itime, nexca) == 1
+
+  if (mod(itime, nexca) == 0) then
+!
+! allocation memoire
+    if (nisurf == is_oce .and. (.not. cumul) ) then
+      sum_error = 0
+      allocate(tmp_sols(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_nsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_rain(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_snow(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_evap(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_tsol(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_fder(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_albe(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_taux(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      allocate(tmp_tauy(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+!!$      allocate(tmp_rriv(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+!!$      allocate(tmp_rcoa(iim,jjm+1,2), stat=error); sum_error = sum_error + error
+      if (sum_error /= 0) then
+        abort_message='Pb allocation variables couplees pour l''ecriture'
+        call abort_gcm(modname,abort_message,1)
+      endif
+    endif
+
+!
+! Mise sur la bonne grille des champs a passer au coupleur
+!
+    cpl_index = 1
+    if (nisurf == is_sic) cpl_index = 2
+    call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+    call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+!!$    call gath2cpl(cpl_rriv(1,cpl_index), tmp_rriv(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+!!$    call gath2cpl(cpl_rcoa(1,cpl_index), tmp_rcoa(1,1,cpl_index), klon, knon,iim,jjm,                  knindex)
+
+!
+! Si le domaine considere est la banquise, on envoie les champs au coupleur
+!
+    if (nisurf == is_sic .and. cumul) then
+      wri_rain = 0.; wri_snow = 0.; wri_rcoa = 0.; wri_rriv = 0. 
+      wri_taux = 0.; wri_tauy = 0.
+      call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jjm, tamp_ind)
+      call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jjm, tamp_ind)
+
+      wri_sol_ice = tmp_sols(:,:,2)
+      wri_sol_sea = tmp_sols(:,:,1)
+      wri_nsol_ice = tmp_nsol(:,:,2)
+      wri_nsol_sea = tmp_nsol(:,:,1)
+      wri_fder_ice = tmp_fder(:,:,2)
+      wri_evap_ice = tmp_evap(:,:,2)
+      wri_evap_sea = tmp_evap(:,:,1)
+!!$PB
+      wri_rriv = cpl_rriv(:,:)
+      wri_rcoa = cpl_rcoa(:,:)
+
+      where (tamp_zmasq /= 1.)
+        deno =  tamp_srf(:,:,1) + tamp_srf(:,:,2)
+        wri_rain = tmp_rain(:,:,1) * tamp_srf(:,:,1) / deno +    &
+      &            tmp_rain(:,:,2) * tamp_srf(:,:,2) / deno
+        wri_snow = tmp_snow(:,:,1) * tamp_srf(:,:,1) / deno +    &
+      &            tmp_snow(:,:,2) * tamp_srf(:,:,2) / deno
+!!$PB
+!!$        wri_rriv = tmp_rriv(:,:,1) * tamp_srf(:,:,1) / deno +    &
+!!$      &            tmp_rriv(:,:,2) * tamp_srf(:,:,2) / deno
+!!$        wri_rcoa = tmp_rcoa(:,:,1) * tamp_srf(:,:,1) / deno +    &
+!!$      &            tmp_rcoa(:,:,2) * tamp_srf(:,:,2) / deno
+        wri_taux = tmp_taux(:,:,1) * tamp_srf(:,:,1) / deno +    &
+      &            tmp_taux(:,:,2) * tamp_srf(:,:,2) / deno
+        wri_tauy = tmp_tauy(:,:,1) * tamp_srf(:,:,1) / deno +    &
+      &            tmp_tauy(:,:,2) * tamp_srf(:,:,2) / deno
+      endwhere
+!
+! on passe les coordonnées de la grille
+!
+
+      CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon)
+      CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat)
+
+      DO i = 1, iim
+        tmp_lon(i,1) = rlon(i+1)
+        tmp_lon(i,jjm + 1) = rlon(i+1)
+      ENDDO
+!
+! sortie netcdf des champs pour le changement de repere
+!
+      ndexct(:)=0
+      CALL histwrite(nidct,'tauxe',itime,wri_taux,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tauyn',itime,wri_tauy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tmp_lon',itime,tmp_lon,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tmp_lat',itime,tmp_lat,iim*(jjm+1),ndexct)
+
+!
+! calcul 3 coordonnées du vent
+!
+      CALL atm2geo (iim , jjm + 1, wri_taux, wri_tauy, tmp_lon, tmp_lat, &
+         & wri_tauxx, wri_tauyy, wri_tauzz )
+!
+! sortie netcdf des champs apres changement de repere et juste avant
+! envoi au coupleur
+!
+      CALL histwrite(nidct,cl_writ(1),itime,wri_sol_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(2),itime,wri_sol_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(3),itime,wri_nsol_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(4),itime,wri_nsol_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(5),itime,wri_fder_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(6),itime,wri_evap_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(7),itime,wri_evap_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(8),itime,wri_rain,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(9),itime,wri_snow,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(10),itime,wri_rcoa,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(11),itime,wri_rriv,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(12),itime,wri_tauxx,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(13),itime,wri_tauyy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(14),itime,wri_tauzz,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(15),itime,wri_tauxx,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(16),itime,wri_tauyy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(17),itime,wri_tauzz,iim*(jjm+1),ndexct)
+      CALL histsync(nidct)
+! pas utile      IF (lafin) CALL histclo(nidct)
+
+      call intocpl(itime, (jjm+1)*iim, wri_sol_ice, wri_sol_sea, wri_nsol_ice,&
+      & wri_nsol_sea, wri_fder_ice, wri_evap_ice, wri_evap_sea, wri_rain, &
+      & wri_snow, wri_rcoa, wri_rriv, wri_tauxx, wri_tauyy, wri_tauzz, &
+      & wri_tauxx, wri_tauyy, wri_tauzz,lafin )
+! 
+      cpl_sols = 0.; cpl_nsol = 0.; cpl_rain = 0.; cpl_snow = 0.
+      cpl_evap = 0.; cpl_tsol = 0.; cpl_fder = 0.; cpl_albe = 0.
+      cpl_taux = 0.; cpl_tauy = 0.; cpl_rriv = 0.; cpl_rcoa = 0.
+!
+! deallocation memoire variables temporaires
+!
+      sum_error = 0
+      deallocate(tmp_sols, stat=error); sum_error = sum_error + error
+      deallocate(tmp_nsol, stat=error); sum_error = sum_error + error
+      deallocate(tmp_rain, stat=error); sum_error = sum_error + error
+      deallocate(tmp_snow, stat=error); sum_error = sum_error + error
+      deallocate(tmp_evap, stat=error); sum_error = sum_error + error
+      deallocate(tmp_fder, stat=error); sum_error = sum_error + error
+      deallocate(tmp_tsol, stat=error); sum_error = sum_error + error
+      deallocate(tmp_albe, stat=error); sum_error = sum_error + error
+      deallocate(tmp_taux, stat=error); sum_error = sum_error + error
+      deallocate(tmp_tauy, stat=error); sum_error = sum_error + error
+!!$PB
+!!$      deallocate(tmp_rriv, stat=error); sum_error = sum_error + error
+!!$      deallocate(tmp_rcoa, stat=error); sum_error = sum_error + error
+      if (sum_error /= 0) then
+        abort_message='Pb deallocation variables couplees'
+        call abort_gcm(modname,abort_message,1)
+      endif
+
+    endif
+
+  endif            ! fin (mod(itime, nexca) == 0)
+!
+! on range les variables lues/sauvegardees dans les bonnes variables de sortie
+!
+  if (nisurf == is_oce) then
+    call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jjm, knindex)
+  else if (nisurf == is_sic) then
+    call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jjm, knindex)
+    call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jjm, knindex)
+  endif
+  pctsrf_new(:,nisurf) = pctsrf_sav(:,nisurf)
+  
+!  if (lafin) call quitcpl
+
+  END SUBROUTINE interfoce_cpl
+!
+!#########################################################################
+!
+
+  SUBROUTINE interfoce_slab(nisurf)
+
+! Cette routine sert d'interface entre le modele atmospherique et un 
+! modele de 'slab' ocean
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!
+! output:
+!
+
+! Parametres d'entree
+  integer, intent(IN) :: nisurf
+
+  END SUBROUTINE interfoce_slab
+!
+!#########################################################################
+!
+  SUBROUTINE interfoce_lim(itime, dtime, jour, &
+     & klon, nisurf, knon, knindex, &
+     & debut,  &
+     & lmt_sst, pctsrf_new)
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst      SST lues dans le fichier de CL
+!   pctsrf_new   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+  integer, intent(IN) :: itime
+  real   , intent(IN) :: dtime
+  integer, intent(IN) :: jour
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+  integer, intent(IN) :: klon
+  integer, dimension(klon), intent(in) :: knindex
+  logical, intent(IN) :: debut
+
+! Parametres de sortie
+  real, intent(out), dimension(klon) :: lmt_sst
+  real, intent(out), dimension(klon,nbsrf) :: pctsrf_new
+
+! Variables locales
+  integer     :: ii
+  INTEGER,save :: lmt_pas     ! frequence de lecture des conditions limites 
+                             ! (en pas de physique)
+  logical,save :: deja_lu    ! pour indiquer que le jour a lire a deja
+                             ! lu pour une surface precedente
+  integer,save :: jour_lu 
+  integer      :: ierr
+  character (len = 20) :: modname = 'interfoce_lim'
+  character (len = 80) :: abort_message
+  character (len = 20),save :: fich ='limit.nc'
+  logical, save     :: newlmt = .TRUE.
+  logical, save     :: check = .FALSE.
+! Champs lus dans le fichier de CL
+  real, allocatable , save, dimension(:) :: sst_lu, rug_lu, nat_lu
+  real, allocatable , save, dimension(:,:) :: pct_tmp
+!
+! quelques variables pour netcdf
+!
+#include "netcdf.inc"
+  integer              :: nid, nvarid
+  integer, dimension(2) :: start, epais
+!
+! Fin déclaration
+!
+    
+  if (debut .and. .not. allocated(sst_lu)) then
+    lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour
+    jour_lu = jour - 1
+    allocate(sst_lu(klon))
+    allocate(nat_lu(klon))
+    allocate(pct_tmp(klon,nbsrf))
+  endif
+
+  if ((jour - jour_lu) /= 0) deja_lu = .false.
+  
+  if (check) write(*,*)modname,' :: jour, jour_lu, deja_lu', jour, jour_lu, deja_lu 
+  if (check) write(*,*)modname,' :: itime, lmt_pas ', itime, lmt_pas,dtime
+
+! Tester d'abord si c'est le moment de lire le fichier
+  if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu) then
+!
+! Ouverture du fichier
+!
+    fich = trim(fich)
+    ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+    if (ierr.NE.NF_NOERR) then
+      abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+      call abort_gcm(modname,abort_message,1)
+    endif
+! 
+! La tranche de donnees a lire:
+!
+    start(1) = 1
+    start(2) = jour + 1
+    epais(1) = klon
+    epais(2) = 1
+!
+    if (newlmt) then
+!
+! Fraction "ocean" 
+!
+      ierr = NF_INQ_VARID(nid, 'FOCE', nvarid)
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Le champ <FOCE> est absent'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_oce))
+#endif
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Lecture echouee pour <FOCE>'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!
+! Fraction "glace de mer" 
+!
+      ierr = NF_INQ_VARID(nid, 'FSIC', nvarid)
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Le champ <FSIC> est absent'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_sic))
+#endif
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Lecture echouee pour <FSIC>'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!
+! Fraction "terre" 
+!
+      ierr = NF_INQ_VARID(nid, 'FTER', nvarid)
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Le champ <FTER> est absent'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_ter))
+#endif
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Lecture echouee pour <FTER>'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!
+! Fraction "glacier terre" 
+!
+      ierr = NF_INQ_VARID(nid, 'FLIC', nvarid)
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Le champ <FLIC> est absent'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais,pct_tmp(1,is_lic))
+#endif
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Lecture echouee pour <FLIC>'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!
+    else  ! on en est toujours a rnatur
+! 
+      ierr = NF_INQ_VARID(nid, 'NAT', nvarid)
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Le champ <NAT> est absent'
+        call abort_gcm(modname,abort_message,1)
+      endif
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, nat_lu)
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, nat_lu)
+#endif
+      if (ierr /= NF_NOERR) then
+        abort_message = 'Lecture echouee pour <NAT>'
+        call abort_gcm(modname,abort_message,1)
+      endif
+!
+! Remplissage des fractions de surface
+! nat = 0, 1, 2, 3 pour ocean, terre, glacier, seaice
+! 
+      pct_tmp = 0.0
+      do ii = 1, klon
+        pct_tmp(ii,nint(nat_lu(ii)) + 1) = 1.
+      enddo
+
+!
+!  On se retrouve avec ocean en 1 et terre en 2 alors qu'on veut le contraire
+!
+      pctsrf_new = pct_tmp
+      pctsrf_new (:,2)= pct_tmp (:,1)
+      pctsrf_new (:,1)= pct_tmp (:,2)
+      pct_tmp = pctsrf_new 
+    endif ! fin test sur newlmt
+!
+! Lecture SST
+!
+    ierr = NF_INQ_VARID(nid, 'SST', nvarid)
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Le champ <SST> est absent'
+      call abort_gcm(modname,abort_message,1)
+    endif
+#ifdef NC_DOUBLE
+    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, sst_lu)
+#else
+    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, sst_lu)
+#endif
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Lecture echouee pour <SST>'
+      call abort_gcm(modname,abort_message,1)
+    endif    
+
+!
+! Fin de lecture
+!
+    ierr = NF_CLOSE(nid)
+    deja_lu = .true.
+    jour_lu = jour
+  endif
+!
+! Recopie des variables dans les champs de sortie
+!
+  lmt_sst = 999999999.
+  do ii = 1, knon
+    lmt_sst(ii) = sst_lu(knindex(ii))
+  enddo
+
+  pctsrf_new(:,is_oce) = pct_tmp(:,is_oce)
+  pctsrf_new(:,is_sic) = pct_tmp(:,is_sic)
+
+  END SUBROUTINE interfoce_lim
+
+!
+!#########################################################################
+!
+  SUBROUTINE interfsur_lim(itime, dtime, jour, &
+     & klon, nisurf, knon, knindex, &
+     & debut,  &
+     & lmt_alb, lmt_rug)
+
+! Cette routine sert d'interface entre le modele atmospherique et un fichier
+! de conditions aux limites
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps courant
+!   dtime        pas de temps de la physique (en s)
+!   jour         jour a lire dans l'annee
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   debut        logical: 1er appel a la physique (initialisation)
+!
+! output:
+!   lmt_sst      SST lues dans le fichier de CL
+!   lmt_alb      Albedo lu 
+!   lmt_rug      longueur de rugosité lue
+!   pctsrf_new   sous-maille fractionnelle
+!
+
+
+! Parametres d'entree
+  integer, intent(IN) :: itime
+  real   , intent(IN) :: dtime
+  integer, intent(IN) :: jour
+  integer, intent(IN) :: nisurf
+  integer, intent(IN) :: knon
+  integer, intent(IN) :: klon
+  integer, dimension(klon), intent(in) :: knindex
+  logical, intent(IN) :: debut
+
+! Parametres de sortie
+  real, intent(out), dimension(klon) :: lmt_alb
+  real, intent(out), dimension(klon) :: lmt_rug
+
+! Variables locales
+  integer     :: ii
+  integer,save :: lmt_pas     ! frequence de lecture des conditions limites 
+                             ! (en pas de physique)
+  logical,save :: deja_lu_sur! pour indiquer que le jour a lire a deja
+                             ! lu pour une surface precedente
+  integer,save :: jour_lu_sur 
+  integer      :: ierr
+  character (len = 20) :: modname = 'interfsur_lim'
+  character (len = 80) :: abort_message
+  character (len = 20),save :: fich ='limit.nc'
+  logical,save     :: newlmt = .false.
+  logical,save     :: check = .FALSE.
+! Champs lus dans le fichier de CL
+  real, allocatable , save, dimension(:) :: alb_lu, rug_lu
+!
+! quelques variables pour netcdf
+!
+#include "netcdf.inc"
+  integer ,save             :: nid, nvarid
+  integer, dimension(2),save :: start, epais
+!
+! Fin déclaration
+!
+    
+  if (debut) then
+    lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour
+    jour_lu_sur = jour - 1
+    allocate(alb_lu(klon))
+    allocate(rug_lu(klon))
+  endif
+
+  if ((jour - jour_lu_sur) /= 0) deja_lu_sur = .false.
+  
+  if (check) write(*,*)modname,':: jour_lu_sur, deja_lu_sur', jour_lu_sur, deja_lu_sur 
+  if (check) write(*,*)modname,':: itime, lmt_pas', itime, lmt_pas
+  call flush(6)
+
+! Tester d'abord si c'est le moment de lire le fichier
+  if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu_sur) then
+!
+! Ouverture du fichier
+!
+    fich = trim(fich)
+    ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+    if (ierr.NE.NF_NOERR) then
+      abort_message = 'Pb d''ouverture du fichier de conditions aux limites'
+      call abort_gcm(modname,abort_message,1)
+    endif
+! 
+! La tranche de donnees a lire:
+ 
+    start(1) = 1
+    start(2) = jour + 1
+    epais(1) = klon
+    epais(2) = 1
+!
+! Lecture Albedo
+!
+    ierr = NF_INQ_VARID(nid, 'ALB', nvarid)
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Le champ <ALB> est absent'
+      call abort_gcm(modname,abort_message,1)
+    endif
+#ifdef NC_DOUBLE
+    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, alb_lu)
+#else
+    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, alb_lu)
+#endif
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Lecture echouee pour <ALB>'
+      call abort_gcm(modname,abort_message,1)
+    endif
+!
+! Lecture rugosité
+!
+    ierr = NF_INQ_VARID(nid, 'RUG', nvarid)
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Le champ <RUG> est absent'
+      call abort_gcm(modname,abort_message,1)
+    endif
+#ifdef NC_DOUBLE
+    ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,epais, rug_lu)
+#else
+    ierr = NF_GET_VARA_REAL(nid,nvarid,start,epais, rug_lu)
+#endif
+    if (ierr /= NF_NOERR) then
+      abort_message = 'Lecture echouee pour <RUG>'
+      call abort_gcm(modname,abort_message,1)
+    endif
+
+!
+! Fin de lecture
+!
+    ierr = NF_CLOSE(nid)
+    deja_lu_sur = .true.
+    jour_lu_sur = jour
+  endif
+!
+! Recopie des variables dans les champs de sortie
+!
+!!$  lmt_alb(:) = 0.0
+!!$  lmt_rug(:) = 0.0
+  lmt_alb(:) = 999999.
+  lmt_rug(:) = 999999.
+  DO ii = 1, knon
+    lmt_alb(ii) = alb_lu(knindex(ii))
+    lmt_rug(ii) = rug_lu(knindex(ii))
+  enddo
+
+  END SUBROUTINE interfsur_lim
+
+!
+!#########################################################################
+!
+
+  SUBROUTINE calcul_fluxs( klon, knon, nisurf, dtime, &
+     & tsurf, p1lay, cal, beta, coef1lay, ps, &
+     & precip_rain, precip_snow, snow, qsol, &
+     & radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+     & petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   qsol         humidite du sol
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+#include "YOETHF.inc"
+#include "FCTTRE.inc"
+#include "indicesol.inc"
+
+! Parametres d'entree
+  integer, intent(IN) :: knon, nisurf, klon
+  real   , intent(IN) :: dtime
+  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
+  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
+  real, dimension(klon), intent(IN) :: ps, q1lay
+  real, dimension(klon), intent(IN) :: tsurf, p1lay, cal, beta, coef1lay
+  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
+  real, dimension(klon), intent(IN) :: radsol, dif_grnd
+  real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay
+  real, dimension(klon), intent(INOUT) :: snow, qsol
+
+! Parametres sorties
+  real, dimension(klon), intent(OUT):: tsurf_new, evap, fluxsens, fluxlat
+  real, dimension(klon), intent(OUT):: dflux_s, dflux_l
+
+! Variables locales
+  integer :: i
+  real, dimension(klon) :: zx_mh, zx_nh, zx_oh
+  real, dimension(klon) :: zx_mq, zx_nq, zx_oq
+  real, dimension(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+  real, dimension(klon) :: zx_sl, zx_k1
+  real, dimension(klon) :: zx_q_0 , d_ts
+  real                  :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+  real                  :: bilan_f, fq_fonte
+  REAL                  :: subli, fsno
+  real, parameter :: t_grnd = 271.35, t_coup = 273.15
+!! PB temporaire en attendant mieux pour le modele de neige
+  REAL, parameter :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!
+  logical, save         :: check = .FALSE.
+  character (len = 20)  :: modname = 'calcul_fluxs'
+  logical, save         :: fonte_neige = .false.
+  real, save            :: max_eau_sol = 150.0
+  character (len = 80) :: abort_message 
+  logical,save         :: first = .true.,second=.false.
+
+  if (check) write(*,*)'Entree ', modname,' surface = ',nisurf
+
+  if (size(coastalflow) /= knon .AND. nisurf == is_ter) then
+    write(*,*)'Bizarre, le nombre de points continentaux'
+    write(*,*)'a change entre deux appels. J''arrete ...'
+    abort_message='Pb run_off'
+    call abort_gcm(modname,abort_message,1)
+  endif
+!
+! Traitement neige et humidite du sol
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!
+  evap = 0.
+  fluxsens=0.
+  fluxlat=0.
+  dflux_s = 0.
+  dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!
+  DO i = 1, knon
+    zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+  IF (thermcep) THEN
+      zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+      zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+      zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+      zx_qs=MIN(0.5,zx_qs)
+      zcor=1./(1.-retv*zx_qs)
+      zx_qs=zx_qs*zcor
+      zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+     &                 /RLVTT / zx_pkh(i)
+    ELSE
+      IF (tsurf(i).LT.t_coup) THEN
+        zx_qs = qsats(tsurf(i)) / ps(i)
+        zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+     &                    / zx_pkh(i)
+      ELSE
+        zx_qs = qsatl(tsurf(i)) / ps(i)
+        zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+     &               / zx_pkh(i)
+      ENDIF
+    ENDIF
+    zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+    zx_qsat(i) = zx_qs
+    zx_coef(i) = coef1lay(i) &
+     & * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
+     & * p1lay(i)/(RD*t1lay(i))
+
+  ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! 
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!
+  do i = 1, knon
+    zx_sl(i) = RLVTT
+    if (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+    zx_k1(i) = zx_coef(i)
+  enddo
+
+
+  do i = 1, knon
+! Q
+    zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
+    zx_mq(i) = beta(i) * zx_k1(i) * &
+     &             (peqAcoef(i) - zx_qsat(i) &
+     &                          + zx_dq_s_dt(i) * tsurf(i)) &
+     &             / zx_oq(i)
+    zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
+     &                              / zx_oq(i)
+
+! H
+    zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
+    zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
+    zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+
+! Tsurface
+    tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+     &             (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+     &                 + dif_grnd(i) * t_grnd * dtime)/ &
+     &          ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+     &                       zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+     &                     + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+    d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+    evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+    fluxlat(i) = - evap(i) * zx_sl(i)
+    fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+! Derives des flux dF/dTs (W m-2 K-1):
+    dflux_s(i) = zx_nh(i)
+    dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+  ENDDO
+
+  END SUBROUTINE calcul_fluxs
+!
+!#########################################################################
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, klon, knon, iim, jjm, knindex)
+
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   iim,jjm      dimension de la grille 2D
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+! input
+  integer                   :: klon, knon, iim, jjm
+  real, dimension(klon)     :: champ_in
+  integer, dimension(klon)  :: knindex
+! output
+  real, dimension(iim,jjm+1)  :: champ_out
+! local
+  integer                   :: i, ig, j
+  real, dimension(klon)     :: tamp
+
+  tamp = 0.
+  do i = 1, knon
+    ig = knindex(i)
+    tamp(ig) = champ_in(i)
+  enddo    
+  ig = 1
+  champ_out(:,1) = tamp(ig)
+  do j = 2, jjm
+    do i = 1, iim
+      ig = ig + 1
+      champ_out(i,j) = tamp(ig)
+    enddo
+  enddo
+  ig = ig + 1
+  champ_out(:,jjm+1) = tamp(ig)
+
+  END SUBROUTINE gath2cpl
+!
+!#########################################################################
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, klon, knon, iim, jjm, knindex)
+
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! 
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!   klon         taille de la grille
+!   iim,jjm      dimension de la grille 2D
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+! input
+  integer                   :: klon, knon, iim, jjm
+  real, dimension(iim,jjm+1)     :: champ_in
+  integer, dimension(klon)  :: knindex
+! output
+  real, dimension(klon)  :: champ_out
+! local
+  integer                   :: i, ig, j
+  real, dimension(klon)     :: tamp
+  logical ,save                  :: check = .false.
+
+  ig = 1
+  tamp(ig) = champ_in(1,1)
+  do j = 2, jjm
+    do i = 1, iim
+      ig = ig + 1
+      tamp(ig) = champ_in(i,j)
+    enddo
+  enddo
+  ig = ig + 1
+  tamp(ig) = champ_in(1,jjm+1)
+
+  do i = 1, knon
+    ig = knindex(i)
+    champ_out(i) = tamp(ig)
+  enddo    
+
+  END SUBROUTINE cpl2gath
+!
+!#########################################################################
+!
+  SUBROUTINE albsno(klon, knon,dtime,agesno,alb_neig_grid, precip_snow)
+  IMPLICIT none
+ 
+  INTEGER :: klon, knon
+  INTEGER, PARAMETER :: nvm = 8
+  REAL   :: dtime
+  REAL, dimension(klon,nvm) :: veget
+  REAL, DIMENSION(klon) :: alb_neig_grid, agesno, precip_snow
+ 
+  INTEGER :: i, nv
+ 
+  REAL, DIMENSION(nvm),SAVE :: init, decay
+  REAL :: as
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+ 
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+    alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+    DO i = 1, knon
+      as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+      alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+    ENDDO
+  ENDDO
+!
+!! modilation en fonction de l'age de la neige
+!
+  DO i = 1, knon
+    agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+            &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+    agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+ 
+  END SUBROUTINE albsno
+!
+!#########################################################################
+!
+
+  SUBROUTINE fonte_neige( klon, knon, nisurf, dtime, &
+     & tsurf, p1lay, cal, beta, coef1lay, ps, &
+     & precip_rain, precip_snow, snow, qsol, &
+     & radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+     & petAcoef, peqAcoef, petBcoef, peqBcoef, &
+     & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifié
+!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   qsol         humidite du sol
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+#include "YOETHF.inc"
+#include "FCTTRE.inc"
+#include "indicesol.inc"
+
+! Parametres d'entree
+  integer, intent(IN) :: knon, nisurf, klon
+  real   , intent(IN) :: dtime
+  real, dimension(klon), intent(IN) :: petAcoef, peqAcoef
+  real, dimension(klon), intent(IN) :: petBcoef, peqBcoef
+  real, dimension(klon), intent(IN) :: ps, q1lay
+  real, dimension(klon), intent(IN) :: tsurf, p1lay, cal, beta, coef1lay
+  real, dimension(klon), intent(IN) :: precip_rain, precip_snow
+  real, dimension(klon), intent(IN) :: radsol, dif_grnd
+  real, dimension(klon), intent(IN) :: t1lay, u1lay, v1lay
+  real, dimension(klon), intent(INOUT) :: snow, qsol
+
+! Parametres sorties
+  real, dimension(klon), intent(INOUT):: tsurf_new, evap, fluxsens, fluxlat
+  real, dimension(klon), intent(INOUT):: dflux_s, dflux_l
+
+! Variables locales
+  integer :: i
+  real, dimension(klon) :: zx_mh, zx_nh, zx_oh
+  real, dimension(klon) :: zx_mq, zx_nq, zx_oq
+  real, dimension(klon) :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+  real, dimension(klon) :: zx_sl, zx_k1
+  real, dimension(klon) :: zx_q_0 , d_ts
+  real                  :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+  real                  :: bilan_f, fq_fonte
+  REAL                  :: subli, fsno
+  real, parameter :: t_grnd = 271.35, t_coup = 273.15
+!! PB temporaire en attendant mieux pour le modele de neige
+  REAL, parameter :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!
+  logical, save         :: check = .FALSE.
+  character (len = 20)  :: modname = 'fonte_neige'
+  logical, save         :: neige_fond = .false.
+  real, save            :: max_eau_sol = 150.0
+  character (len = 80) :: abort_message 
+  logical,save         :: first = .true.,second=.false.
+
+  if (check) write(*,*)'Entree ', modname,' surface = ',nisurf
+
+! Initialisations
+  DO i = 1, knon
+    zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+  IF (thermcep) THEN
+      zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+      zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+      zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+      zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+      zx_qs=MIN(0.5,zx_qs)
+      zcor=1./(1.-retv*zx_qs)
+      zx_qs=zx_qs*zcor
+      zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+     &                 /RLVTT / zx_pkh(i)
+    ELSE
+      IF (tsurf(i).LT.t_coup) THEN
+        zx_qs = qsats(tsurf(i)) / ps(i)
+        zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+     &                    / zx_pkh(i)
+      ELSE
+        zx_qs = qsatl(tsurf(i)) / ps(i)
+        zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+     &               / zx_pkh(i)
+      ENDIF
+    ENDIF
+    zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+    zx_qsat(i) = zx_qs
+    zx_coef(i) = coef1lay(i) &
+     & * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
+     & * p1lay(i)/(RD*t1lay(i))
+  ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! 
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!
+  do i = 1, knon
+    zx_sl(i) = RLVTT
+    if (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+    zx_k1(i) = zx_coef(i)
+  enddo
+
+
+  do i = 1, knon
+! Q
+    zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
+    zx_mq(i) = beta(i) * zx_k1(i) * &
+     &             (peqAcoef(i) - zx_qsat(i) &
+     &                          + zx_dq_s_dt(i) * tsurf(i)) &
+     &             / zx_oq(i)
+    zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
+     &                              / zx_oq(i)
+
+! H
+    zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
+    zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
+    zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+  enddo
+
+
+  WHERE (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+  WHERE (evap > 0 ) snow = MAX(0.0, snow - (evap * dtime))
+  qsol = qsol + (precip_rain - evap) * dtime
+!
+! Y'a-t-il fonte de neige?
+!
+  do i = 1, knon
+    neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+     & .AND. tsurf_new(i) >= RTT)
+    if (neige_fond) then
+      fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+      snow(i) = max(0., snow(i) - fq_fonte)
+      qsol(i) = qsol(i) + fq_fonte 
+      tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+      IF (nisurf == is_sic .OR. nisurf == is_lic ) tsurf_new(i) = RTT -1.8
+      d_ts(i) = tsurf_new(i) - tsurf(i)
+!      zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!      zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+!!$      evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+!!$      fluxlat(i) = - evap(i) * zx_sl(i)
+!!$      fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+! Derives des flux dF/dTs (W m-2 K-1):
+!!$      dflux_s(i) = zx_nh(i)
+!!$      dflux_l(i) = (zx_sl(i) * zx_nq(i))
+!!$      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!!$     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!!$     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!!$      bilan_f = max(0., bilan_f)
+!!$      fq_fonte = bilan_f / zx_sl(i)
+    endif
+    IF (nisurf == is_ter)  &
+       &  run_off(i) = run_off(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+    qsol(i) = MIN(qsol(i), max_eau_sol) 
+  enddo
+
+  END SUBROUTINE fonte_neige
+!
+!#########################################################################
+!
+  END MODULE interface_surf
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/mpiclim.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/mpiclim.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/mpiclim.h	(revision 300)
@@ -0,0 +1,21 @@
+C
+C -- mpiclim.h  26-10-99   Version 2.4   Author: Jean Latour (F.S.E.)
+C    *********
+C@
+C@  Contents : variables related to MPI-2 message passing
+C@  --------
+C@
+C@ -- mpi_totproc: number of processors on which to launch each model
+C@
+C@ -- mpi_nproc: number of processors involved in the coupling for
+C@               each model
+C@ -- cmpi_modnam: models name
+C     -----------------------------------------------------------------
+C
+      INTEGER*4 mpi_totproc(1:CLIM_MaxMod-1),mpi_nproc(0:CLIM_MaxMod-1)
+C
+      CHARACTER*6 cmpi_modnam(1:CLIM_MaxMod-1)
+C
+      common/CLIM_mpiclim/mpi_totproc, mpi_nproc, cmpi_modnam 
+C
+C     -----------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/nuage.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/nuage.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/nuage.F	(revision 300)
@@ -37,6 +37,8 @@
       REAL zflwp, zradef, zfice, zmsac
 c
-      REAL radius, rad_froid, rad_chaud
-      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
       REAL coef, coef_froi, coef_chau
       PARAMETER (coef_chau=0.13, coef_froi=0.09)
@@ -51,4 +53,6 @@
       DO k = 1, klev
       DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
          pclc(i,k) = MAX(pclc(i,k), seuil_neb)
          zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)
@@ -127,5 +131,5 @@
       RETURN
       END
-      SUBROUTINE diagcld(paprs,pplay,t,q,rain,snow,kbot,ktop,
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
      .                   diafra,dialiq)
       IMPLICIT none
@@ -155,11 +159,4 @@
       REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
       REAL dialiq(klon,klev) ! eau liquide nuageuse
-c
-c Options a choisir:
-      LOGICAL ok_conv ! prendre en compte les nuages convectifs
-      PARAMETER (ok_conv=.TRUE.)
-      LOGICAL ok_inve ! prendre en compte les nuages d'inversion
-CCC      PARAMETER (ok_inve=.TRUE.)
-      PARAMETER (ok_inve=.FALSE.)
 c
 c Constantes ajustables:
@@ -177,23 +174,8 @@
       REAL ZEPSCR
       PARAMETER (ZEPSCR=1.0E-10)
-      REAL CLOIA, CLOIB, CLOIC, CLOID
-ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
-      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
-      REAL RGAMMAS
-      PARAMETER (RGAMMAS=0.05)
-      REAL CRHL
-ccc      PARAMETER (CRHL=0.15)
-      PARAMETER (CRHL=0.70)
-      REAL t_coup
-      PARAMETER (t_coup=234.0)
 c
 c Variables locales:
-      INTEGER i, k, kb, invb(klon)
-      REAL zcc(klon), zqs, zrhb, zcll, zdthmin(klon), zdthdp
-      REAL zdelta, zcor
-c
-c Fonctions thermodynamiques:
-#include "YOETHF.h"
-#include "FCTTRE.h"
+      INTEGER i, k
+      REAL zcc(klon)
 c
 c Initialisation:
@@ -205,6 +187,4 @@
       ENDDO
       ENDDO
-c
-      IF (ok_conv) THEN
 c
       DO i = 1, klon ! Calculer la fraction nuageuse
@@ -215,13 +195,11 @@
       ENDIF
       ENDDO
-cn
+c
       DO i = 1, klon ! pour traiter les enclumes
-         diafra(i,ktop(i)) = zcc(i) * CCFCT
-ccc      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
       IF ((zcc(i).GE.CANVH) .AND.
      .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
-     .   diafra(i,ktop(i)) = MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB))      
-cc     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
-cc     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
       dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
       ENDDO
@@ -230,6 +208,5 @@
       DO i = 1, klon
       IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
-           diafra(i,k)=zcc(i)*CCFCT
-cc         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
          dialiq(i,k)=CCLWMR*diafra(i,k)
       ENDIF
@@ -237,8 +214,54 @@
       ENDDO
 c
-      ENDIF ! ok_conv
-c
-      IF (ok_inve) THEN
-
+      RETURN
+      END
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      IMPLICIT none
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
       DO i = 1, klon
          invb(i) = klev
@@ -280,11 +303,8 @@
      .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
          zcll=MIN(1.0,MAX(0.0,zcll))
-cc         diafra(i,kb) = MAX(diafra(i,kb),zcll)
-cc         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
-         diafra(i,kb) = zcll
-         dialiq(i,kb)= zcll* RGAMMAS*zqs        
-      ENDDO
-c
-      ENDIF ! ok_inve
-c
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+c
+      RETURN
       END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/oasis.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.F	(revision 300)
@@ -1,22 +1,7 @@
-      SUBROUTINE inicma(kastp,kexch,kstep)
-      IMPLICIT none
-c
-      INTEGER kastp, kexch, kstep
-c
-      INTEGER ime
-      PARAMETER (ime = 1)
-c
+C $Id$
 C****
-C               *****************
-C               * OASIS ROUTINE *
-C               * ------------- *
-C               *****************
 C
 C**** *INICMA*  - Initialize coupled mode communication for atmosphere
-C
-C     Purpose:
-C     -------
-C     Exchange process identifiers and timestep information
-C     between AGCM, OGCM and COUPLER.
+C                 and exchange some initial information with Oasis
 C
 C     Input:
@@ -24,43 +9,39 @@
 C       KASTP  : total number of timesteps in atmospheric model
 C       KEXCH  : frequency of exchange (in time steps)
-C       KSTEP  : timestep value (in seconds)
-C
-C     Method:
-C     ------
-C     Use named pipes(FIFO) to exchange process identifiers
-C     between the programs
-C
-C     Externals:
-C     ---------
-C     GETPID, MKNOD
-C
-C     Reference:
-C     ---------
-C     See Epicoa 0803 (1992)
-C
-C     Author:
-C     -------
-C     Laurent Terray  92-09-01
+C       KSTEP  : length of timestep (in seconds)
 C
 C     -----------------------------------------------------------
 C
+      SUBROUTINE inicma(kastp,kexch,kstep,imjm)
+c
+c     INCLUDE 'param.h'
+c
+      INTEGER kastp, kexch, kstep,imjm
+      INTEGER iparal(3)
+      INTEGER ifcpl, idt, info, imxtag, istep, jf
+c
+      INCLUDE 'param_cou.h'
+      INCLUDE 'inc_cpl.h'
+      CHARACTER*3 cljobnam      ! experiment name
+      CHARACTER*6 clmodnam      ! model name
+c     EM: not used by Oasis2.4
+CEM      CHARACTER*6 clbid(2)      ! for CLIM_Init call (not used)
+CEM                                ! must be dimensioned by the number of models
+CEM      INTEGER nbid(2)           ! for CLIM_Init call (not used)
+CEM                                ! must be dimensioned by the number of models
+      CHARACTER*5 cloasis       ! coupler name (Oasis)
       INTEGER imess(4)
-      INTEGER getpid, mknod ! system functions
-      CHARACTER*80 clcmd
-      CHARACTER*8 pipnom, fldnom
-      INTEGER ierror
-C
-#include "dimensions.h"
-#include "dimphy.h"
-#include "oasis.h"
-#include "clim.h"
-c
-      INTEGER iparal(3)
-      INTEGER istep, ifcpl, idt, info, imxtag
-c
-      INTEGER mode, iret, isize
-C
+      INTEGER getpid            ! system functions
       INTEGER nuout
+CEM      LOGICAL llmodel
       PARAMETER (nuout = 6)
+c
+      INCLUDE 'clim.h'
+      INCLUDE 'mpiclim.h'
+c
+      INCLUDE 'oasis.h' ! contains the name of communication technique. Here
+                        ! cchan=CLIM only is possible.
+c			! ctype=MPI2
+c
 C     -----------------------------------------------------------
 C
@@ -75,1234 +56,593 @@
       WRITE(nuout,*) ' '
 c
-      IF (cchain.EQ."PIPE") THEN
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Making pipes for fields to receive from CPL"
-      WRITE(nuout,*) " "
-c
-c zxli(le17fev97): je ne comprends pas pourquoi il faut
-c                  avoir 2 noms pour un seul pipe
-c
-      pipnom = "SISUTESU"
-      fldnom = "Sisutesu"
-#ifdef CRAY
-      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "SIALBEDO"
-      fldnom = "Sialbedo"
-#ifdef CRAY
-      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "SIICECOV"
-      fldnom = "Siicecov"
-#ifdef CRAY
-      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "SIICEALB"
-      fldnom = "Siicealb"
-#ifdef CRAY
-      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Making pipes for fields to send to CPL"
-      WRITE(nuout,*) " "
-c
-      pipnom = "CONSFTOT"
-      fldnom = "Consftot"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COSSTSST"
-      fldnom = "Cosstsst"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "CODFLXDT"
-      fldnom = "Codflxdt"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COSHFTOT"
-      fldnom = "Coshftot"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COALBSUR"
-      fldnom = "Coalbsur"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COTOSPSU"
-      fldnom = "Cotospsu"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COTOLPSU"
-      fldnom = "Cotolpsu"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COTFSHSU"
-      fldnom = "Cotfshsu"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "CORUNCOA"
-      fldnom = "Coruncoa"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "CORIVFLU"
-      fldnom = "Corivflu"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COZOTAUX"
-      fldnom = "Cozotaux"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COMETAUY"
-      fldnom = "Cometauy"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COZOTAU2"
-      fldnom = "Cozotau2"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      pipnom = "COMETAU2"
-      fldnom = "Cometau2"
-#ifdef CRAY
-      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-      WRITE(nuout,'(a80)') clcmd
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-      WRITE(nuout,'(a80)') clcmd
-#endif
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "All pipes have been made"
-      WRITE(nuout,*) " "
-      CALL flush(nuout)
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Communication test between ATM and CPL"
-      WRITE(nuout,*) " "
-c
-      WRITE (pipnom,'(a6,i2.2)') "Preadm", ime
-#ifdef CRAY
-      clcmd = "assign -s u f:"//pipnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-#endif
-      WRITE(nuout,'(a80)') clcmd
-      imess(1) = kastp
-      imess(2) = kexch
-      imess(3) = kstep
-      imess(4) = getpid()
-#ifdef CRAY
-      WRITE (pipnom) imess ! send message to pipe
-#else
-      iret=0
-      isize=4
-      CALL pipwrite(pipnom, imess, isize, iret)
-#endif
-      WRITE(nuout,*) "Msg sent to pipe "//pipnom
-      CALL flush(nuout)
-c
-      WRITE (pipnom,'(a6,i2.2)') "Pwritm", ime
-#ifdef CRAY
-      clcmd = "assign -s unblocked f:"//pipnom
-      CALL assign(clcmd, ierror)
-      ierror = mknod (pipnom, 4480, 0)
-#else
-      clcmd = "CALL makepipe("//pipnom//",...,...)"
-      mode = o'010600'
-      iret = 0
-      CALL makepipe(pipnom, mode, iret)
-#endif
-      WRITE(nuout,'(a80)') clcmd
-c
-      WRITE(nuout,*) "Waiting for the pipe "//pipnom
-      CALL flush(nuout)
-#ifdef CRAY
-      READ (pipnom) imess ! read message from pipe
-#else
-      isize=1
-      iret =0
-      CALL pipread(pipnom,imess,isize,iret)
-#endif
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Communication test between ATM and CPL is OK"
-      WRITE(nuout,*) " total simulation time in oasis = ", imess(1)
-      WRITE(nuout,*) " total number of iterations is  = ", imess(2)
-      WRITE(nuout,*) " value of oasis timestep  is    = ", imess(3)
-      WRITE(nuout,*) " process id for oasis  is       = ", imess(4)
-      WRITE(nuout,*) " "
-      CALL flush(nuout)
-c
-      ELSE ! cchain.EQ."CLIM"
-c
-      CALL CLIM_Init ( 'CLI', 'lmd.xx', 3, 7,
+c     Define the model name
+c
+      clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+c
+c     Define the coupler name
+c
+      cloasis = 'Oasis'        !  always 'Oasis' as in the coupler
+c
+c
+c     Define symbolic name for fields exchanged from atmos to coupler,
+c         must be the same as (1) of the field  definition in namcouple:
+c
+      cl_writ(1)='COSHFICE'
+      cl_writ(2)='COSHFOCE'
+      cl_writ(3)='CONSFICE'
+      cl_writ(4)='CONSFOCE'
+      cl_writ(5)='CODFLXDT'
+c      cl_writ(6)='COICTEMP'
+      cl_writ(6)='COTFSICE'
+      cl_writ(7)='COTFSOCE'
+      cl_writ(8)='COTOLPSU'
+      cl_writ(9)='COTOSPSU'
+      cl_writ(10)='CORUNCOA'
+      cl_writ(11)='CORIVFLU'
+c$$$      cl_writ(12)='COZOTAUX'
+c$$$      cl_writ(13)='COZOTAUV'
+c$$$      cl_writ(14)='COMETAUY'
+c$$$      cl_writ(15)='COMETAUU'
+      cl_writ(12)='COTAUXXU'
+      cl_writ(13)='COTAUYYU'
+      cl_writ(14)='COTAUZZU'
+      cl_writ(15)='COTAUXXV'
+      cl_writ(16)='COTAUYYV'
+      cl_writ(17)='COTAUZZV'
+c
+c     Define files name for fields exchanged from atmos to coupler,
+c         must be the same as (6) of the field  definition in namcouple:
+c
+      cl_f_writ(1)='flxatmos'
+      cl_f_writ(2)='flxatmos'
+      cl_f_writ(3)='flxatmos'
+      cl_f_writ(4)='flxatmos'
+      cl_f_writ(5)='flxatmos'
+      cl_f_writ(6)='flxatmos'
+      cl_f_writ(7)='flxatmos'
+      cl_f_writ(8)='flxatmos'
+      cl_f_writ(9)='flxatmos'
+      cl_f_writ(10)='flxatmos'
+      cl_f_writ(11)='flxatmos'
+      cl_f_writ(12)='flxatmos'
+      cl_f_writ(13)='flxatmos'
+      cl_f_writ(14)='flxatmos'
+      cl_f_writ(15)='flxatmos'
+      cl_f_writ(16)='flxatmos'
+      cl_f_writ(17)='flxatmos'
+
+c
+c
+c     Define symbolic name for fields exchanged from coupler to atmosphere,
+c         must be the same as (2) of the field  definition in namcouple:
+c
+      cl_read(1)='SISUTESW'
+      cl_read(2)='SIICECOV'
+      cl_read(3)='SIICEALW'
+      cl_read(4)='SIICTEMW'
+c
+c     Define files names for fields exchanged from coupler to atmosphere,
+c         must be the same as (7) of the field  definition in namcouple:
+c
+      cl_f_read(1)='sstatmos'
+      cl_f_read(2)='sstatmos'
+      cl_f_read(3)='sstatmos'
+      cl_f_read(4)='sstatmos'
+c
+c
+c     Define the number of processors involved in the coupling for
+c     Oasis (=1) and each model (as last two INTEGER on $CHATYPE line
+c     in the namcouple); they will be stored in a COMMON in mpiclim.h
+c     (used for CLIM/MPI2 only)
+      mpi_nproc(0)=1
+      mpi_nproc(1)=1
+      mpi_nproc(2)=1 
+c
+c     Define infos to be sent initially to oasis
+c
+      imess(1) = kastp      ! total number of timesteps in atmospheric model
+      imess(2) = kexch      ! period of exchange (in time steps)
+      imess(3) = kstep      ! length of atmospheric timestep (in seconds)
+      imess(4) = getpid()   ! PID of atmospheric model
+c
+c     Initialization and exchange of initial info in the CLIM technique
+c
+      IF (cchan.eq.'CLIM') THEN
+c
+c     Define the experiment name :
+c
+          cljobnam = 'CLI'      ! as $JOBNAM in namcouple
+c
+c         Start the coupling 
+c         (see lib/clim/src/CLIM_Init for the definition of input parameters)
+c
+cEM          clbid(1)='      '
+cEM          clbid(2)='      '
+cEM          nbid(1)=0
+cEM          nbid(2)=0
+CEM          llmodel=.true.
+c
+c         Define the number of processors used by each model as in
+c         $CHATYPE line of namcouple (used for CLIM/MPI2 only) 
+          mpi_totproc(1)=1
+          mpi_totproc(2)=1
+c
+c         Define names of each model as in $NBMODEL line of namcouple
+c         (used for CLIM/MPI2 only)        
+          cmpi_modnam(1)='lmdz.x'
+          cmpi_modnam(2)='opa.xx'
+c         Start the coupling 
+c
+          CALL CLIM_Init ( cljobnam, clmodnam, 3, 7,
      *                 kastp, kexch, kstep,
-     *                 5, 1200, 300, info )
-      IF (info.EQ.CLIM_Ok) THEN
-         WRITE(nuout,*) "inicma: CLIM_Init OK"
-      ELSE
-         WRITE(nuout,*) "inicma: CLIM_Init erreur:", info
-         CALL ABORT("STOP in inicma")
-      ENDIF
-c
-      iparal ( CLIM_Strategy ) = CLIM_Serial
-      iparal ( CLIM_Length   ) = iim*(jjm+1)
-      iparal ( CLIM_Offset   ) = 0
-c
-      CALL CLIM_Define ('SISUTESU', CLIM_In , CLIM_Double, iparal, info)
-      CALL CLIM_Define ('SIALBEDO', CLIM_In , CLIM_Double, iparal, info)
-      CALL CLIM_Define ('SIICECOV', CLIM_In , CLIM_Double, iparal, info)
-      CALL CLIM_Define ('SIICEALB', CLIM_In , CLIM_Double, iparal, info)
-c
-      CALL CLIM_Define ('CONSFTOT', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COSSTSST', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('CODFLXDT', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COSHFTOT', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COALBSUR', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COTOSPSU', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COTOLPSU', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COTFSHSU', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('CORUNCOA', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('CORIVFLU', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COZOTAUX', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COMETAUY', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COZOTAU2', CLIM_Out , CLIM_Double, iparal,info)
-      CALL CLIM_Define ('COMETAU2', CLIM_Out , CLIM_Double, iparal,info)
-      WRITE(nuout,*) 'inicma : CLIM_Define ok '
-c
-      CALL CLIM_Start ( imxtag, info )
-      IF (info.NE.CLIM_Ok) THEN
-          WRITE (nuout,*) "inicma: CLIM_Start pb. ", info
-          CALL ABORT("STOP in inicma")
-      ELSE
-          WRITE (nuout,*)  "inicma: CLIM_Start OK"
-      ENDIF
-c
-      CALL CLIM_Stepi ("oasis", istep, ifcpl, idt, info)
-      IF (info .NE. CLIM_Ok) THEN
-          WRITE (nuout,*) "inicma: CLIM_Stepi pb. ", info
-          CALL ABORT("STOP in inicma")
-      ELSE
-          WRITE (nuout,*) "inicma: CLIM_Stepi OK"
-          WRITE (nuout,*) " number of tstep in oasis ", istep
-          WRITE (nuout,*) " exchange frequency in oasis ", ifcpl
-          WRITE (nuout,*) " length of tstep in oasis ", idt
-      ENDIF
-c
-      ENDIF
-c
-      RETURN
-      END
-      SUBROUTINE fromcpl(jour, imjm, sst, sic, alb_sst, alb_sic)
+     *                 5, 3600, 3600, info )
+c
+          IF (info.ne.CLIM_Ok) THEN
+              WRITE ( nuout, *) ' inicma : pb init clim '
+              WRITE ( nuout, *) ' error code is = ', info
+              CALL halte('STOP in inicma')
+            ELSE
+              WRITE(nuout,*) 'inicma : init clim ok '
+          ENDIF
+c
+c         For each coupling field, association of a port to its symbolic name
+c
+c         -Define the parallel decomposition associated to the port of each
+c          field; here no decomposition for all ports.
+          iparal ( clim_strategy ) = clim_serial 
+          iparal ( clim_length   ) = imjm
+          iparal ( clim_offset   ) = 0
+c
+c         -Loop on total number of coupler-to-atmosphere fields
+c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
+          DO jf=1, jpfldo2a
+            CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal
+     $          , info )  
+          END DO 
+c
+c         -Loop on total number of atmosphere-to-coupler fields 
+c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
+          DO jf=1, jpflda2o1+jpflda2o2
+            CALL CLIM_Define (cl_writ(jf), clim_out , clim_double,
+     $          iparal, info )   
+          END DO 
+c
+          WRITE(nuout,*) 'inicma : clim_define ok '
+c
+c         -Join a pvm group, wait for other programs and broadcast usefull 
+c          informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start)
+          CALL CLIM_Start ( imxtag, info )
+          IF (info.ne.clim_ok) THEN
+              WRITE ( nuout, *) 'inicma : pb start clim '
+              WRITE ( nuout, *) ' error code is = ', info
+              CALL halte('stop in inicma')
+            ELSE
+              WRITE ( nuout, *)  'inicma : start clim ok '
+          ENDIF
+c
+c         -Get initial information from Oasis
+c          (see lib/clim/src/CLIM_Stepi)
+          CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info)
+          IF (info .NE. clim_ok) THEN
+              WRITE ( UNIT = nuout, FMT = *)
+     $            ' warning : problem in getting step info ',
+     $            'from oasis '
+              WRITE (UNIT = nuout, FMT = *)
+     $            ' =======   error code number = ', info
+            ELSE
+              WRITE (UNIT = nuout, FMT = *)
+     $            ' got step information from oasis '
+          ENDIF
+          WRITE ( nuout, *) ' number of tstep in oasis ', istep
+          WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl
+          WRITE ( nuout, *) ' length of tstep in oasis ', idt
+      ENDIF 
+
+      RETURN
+      END
+
+c $Id$
+      SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo)
+c ======================================================================
+c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST 
+c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages)
+c technique. 
+c======================================================================
       IMPLICIT none
-c
-c Laurent Z.X Li (Feb. 10, 1997): It reads the SST and Sea-Ice
-c provided by the coupler. Of course, it waits until it receives
-c the signal from the corresponding pipes in the case of utilizing
-c the pipe technique.
-c
-      INTEGER imjm, jour
-      REAL sst(imjm)      ! sea surface temperature
-      REAL alb_sst(imjm)  ! open sea albedo
-      REAL sic(imjm)      ! sea ice cover
-      REAL alb_sic(imjm)  ! sea ice albedo
-c
-      INTEGER nuout   ! listing output unit
+      INTEGER imjm, kt
+      REAL sst(imjm)          ! sea-surface-temperature
+      REAL gla(imjm)          ! sea-ice
+      REAL tice(imjm)          ! temp glace
+      REAL albedo(imjm)          ! albedo glace
+c
+      INTEGER nuout             ! listing output unit
       PARAMETER (nuout=6)
 c
       INTEGER nuread, ios, iflag, icpliter
-      CHARACTER*8 pipnom ! name for the pipe
-      CHARACTER*8 fldnom ! name for the field
-      CHARACTER*8 filnom ! name for the data file
-c
-#include "oasis.h"
-#include "clim.h"
-      INTEGER info, jktm1
-      INTEGER iret, isize
-c
-      WRITE (nuout,*) " "
-      WRITE (nuout,*) "Fromcpl: Read fields from CPL"
-      WRITE (nuout,*) " "
+      INTEGER info, jf
+c
+      INCLUDE 'clim.h'
+c
+      INCLUDE 'oasis.h'
+      INCLUDE 'param_cou.h'
+c
+      INCLUDE 'inc_cpl.h'
+c
+c
+      WRITE (nuout,*) ' '
+      WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
+      WRITE (nuout,*) ' '
       CALL flush (nuout)
-c
-      IF (cchain.EQ."PIPE") THEN
-c
-c sea-surface-temperature:
-c
-      pipnom = "Sisutesu"
-      fldnom = "SISUTESU"
-      filnom = "atmsst"
-      WRITE (nuout,*) "Waiting for the pipe "//pipnom
-      CALL flush (nuout)
-#ifdef CRAY
-      READ (pipnom) icpliter
-#else
-      iret = 0
-      isize = 1
-      CALL pipread(pipnom, icpliter, isize, iret)
-#endif
-      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      nuread = 99
-      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(nuout,*) "Error while connecting "//filnom, nuread
-          CALL flush (nuout)
-          CALL ABORT("STOP in Fromcpl")
-      ENDIF
-      REWIND (UNIT = nuread)
-      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      CALL locread(fldnom, sst, imjm, nuread, iflag)
-      IF (iflag .NE. 0) THEN
-          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
-          WRITE(nuout,*) "jour, iflag = ", jour, iflag
-          CALL flush (nuout)
-          CALL ABORT('STOP in Fromcpl')
-      ENDIF
-      CLOSE(nuread)
-      WRITE(nuout,*) "Succesful for reading "//fldnom
-      CALL flush (nuout)
-c
-c open sea albedo:
-c
-      pipnom = "Sialbedo"
-      fldnom = "SIALBEDO"
-      filnom = "atmice"
-      WRITE (nuout,*) "Waiting for the pipe "//pipnom
-      CALL flush (nuout)
-#ifdef CRAY
-      READ (pipnom) icpliter
-#else
-      iret = 0
-      isize = 1
-      CALL pipread(pipnom, icpliter, isize, iret)
-#endif
-      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      nuread = 99
-      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(nuout,*) "Error while connecting "//filnom, nuread
-          CALL flush (nuout)
-          CALL ABORT("STOP in Fromcpl")
-      ENDIF
-      REWIND (UNIT = nuread)
-      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      CALL locread(fldnom, alb_sst, imjm, nuread, iflag)
-      IF (iflag .NE. 0) THEN
-          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
-          WRITE(nuout,*) "jour, iflag = ", jour, iflag
-          CALL flush (nuout)
-          CALL ABORT('STOP in Fromcpl')
-      ENDIF
-      CLOSE(nuread)
-      WRITE(nuout,*) "Succesful for reading "//fldnom
-      CALL flush (nuout)
-c
-c sea-ice cover:
-c
-      pipnom = "Siicecov"
-      fldnom = "SIICECOV"
-      filnom = "atmice"
-      WRITE (nuout,*) "Waiting for the pipe "//pipnom
-      CALL flush (nuout)
-#ifdef CRAY
-      READ (pipnom) icpliter
-#else
-      iret = 0
-      isize = 1
-      CALL pipread(pipnom, icpliter, isize, iret)
-#endif
-      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      nuread = 99
-      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(nuout,*) "Error while connecting "//filnom, nuread
-          CALL flush (nuout)
-          CALL ABORT("STOP in Fromcpl")
-      ENDIF
-      REWIND (UNIT = nuread)
-      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      CALL locread(fldnom, sic, imjm, nuread, iflag)
-      IF (iflag .NE. 0) THEN
-          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
-          WRITE(nuout,*) "jour, iflag = ", jour, iflag
-          CALL flush (nuout)
-          CALL ABORT('STOP in Fromcpl')
-      ENDIF
-      CLOSE(nuread)
-      WRITE(nuout,*) "Succesful for reading "//fldnom
-      CALL flush (nuout)
-c
-c sea-ice albedo:
-c
-      pipnom = "Siicealb"
-      fldnom = "SIICEALB"
-      filnom = "atmice"
-      WRITE (nuout,*) "Waiting for the pipe "//pipnom
-      CALL flush (nuout)
-#ifdef CRAY
-      READ (pipnom) icpliter
-#else
-      iret = 0
-      isize = 1
-      CALL pipread(pipnom, icpliter, isize, iret)
-#endif
-      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      nuread = 99
-      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(nuout,*) "Error while connecting "//filnom, nuread
-          CALL flush (nuout)
-          CALL ABORT("STOP in Fromcpl")
-      ENDIF
-      REWIND (UNIT = nuread)
-      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
-      CALL flush (nuout)
-      CALL locread(fldnom, alb_sic, imjm, nuread, iflag)
-      IF (iflag .NE. 0) THEN
-          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
-          WRITE(nuout,*) "jour, iflag = ", jour, iflag
-          CALL flush (nuout)
-          CALL ABORT('STOP in Fromcpl')
-      ENDIF
-      CLOSE(nuread)
-      WRITE(nuout,*) "Succesful for reading "//fldnom
-      CALL flush (nuout)
-c
-      ELSE ! cchain.EQ."CLIM"
-c
-      jktm1=jour-1
-c
-      CALL CLIM_Import ('SISUTESU', jktm1, sst, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE(nuout,*)'Pb in reading ', 'SISUTESU'
-         WRITE(nuout,*)'Atmosphere jour is = ',jour
-         WRITE(nuout,*)'Couplage kt is = ',jktm1
-         WRITE(nuout,*)'CLIM error code is = ', info
-         WRITE(nuout,*)'STOP in Fromcpl'
-         CALL abort
-      ENDIF
-c
-      CALL CLIM_Import ('SIALBEDO', jktm1, alb_sst, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE(nuout,*)'Pb in reading ', 'SIALBEDO'
-         WRITE(nuout,*)'Atmosphere jour is = ',jour
-         WRITE(nuout,*)'Couplage kt is = ',jktm1
-         WRITE(nuout,*)'CLIM error code is = ', info
-         WRITE(nuout,*)'STOP in Fromcpl'
-         CALL abort
-      ENDIF
-c
-      CALL CLIM_Import ('SIICECOV', jktm1, sic, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE(nuout,*)'Pb in reading ', 'SIICECOV'
-         WRITE(nuout,*)'Atmosphere jour is = ',jour
-         WRITE(nuout,*)'Couplage kt is = ',jktm1
-         WRITE(nuout,*)'CLIM error code is = ', info
-         WRITE(nuout,*)'STOP in Fromcpl'
-         CALL abort
-      ENDIF
-c
-      CALL CLIM_Import ('SIICEALB', jktm1, alb_sic, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE(nuout,*)'Pb in reading ', 'SIICEALB'
-         WRITE(nuout,*)'Atmosphere jour is = ',jour
-         WRITE(nuout,*)'Couplage kt is = ',jktm1
-         WRITE(nuout,*)'CLIM error code is = ', info
-         WRITE(nuout,*)'STOP in Fromcpl'
-         CALL abort
-      ENDIF
-c
-      ENDIF ! fin de test sur cchain
-c
-      RETURN
-      END
-
-      SUBROUTINE locread (cdfldn, pfield, kdimax, knulre, kflgre)
-      IMPLICIT none
-      INTEGER kdimax, knulre, kflgre
-C****
-C               *****************************
-C               * OASIS ROUTINE  -  LEVEL 0 *
-C               * -------------     ------- *
-C               *****************************
-C
-C**** *locread*  - Read binary field on unit knulre
-C
-C     Purpose:
-C     -------
-C     Find string cdfldn on unit knulre and read array pfield
-C
-C**   Interface:
-C     ---------
-C       *CALL*  *locread (cdfldn, pfield, kdimax, knulre, kflgre)*
-C
-C     Input:
-C     -----
-C                cdfldn : character string locator
-C                kdimax : dimension of field to be read 
-C                knulre : logical unit to be read 
-C
-C     Output:
-C     ------
-C                pfield : field array (real 1D)
-C                kflgre : error status flag
-C
-C     Workspace:
-C     ---------
-C     None
-C
-C     Externals:
-C     ---------
-C     None
-C
-C     Reference:
-C     ---------
-C     See OASIS manual (1995) 
-C
-C     History:
-C     -------
-C       Version   Programmer     Date      Description
-C       -------   ----------     ----      -----------  
-C       2.0       L. Terray      95/09/01  created
-C
-C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-C
-C* ---------------------------- Include files ---------------------------
-C
-C
-C* ---------------------------- Argument declarations -------------------
-C
-      REAL pfield(kdimax)
-      CHARACTER*8 cdfldn
-C
-C* ---------------------------- Local declarations ----------------------
-C
-      CHARACTER*8 clecfl
-      INTEGER nulou
-c
-      nulou = 6
-C
-C* ---------------------------- Poema verses ----------------------------
-C
-C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-C
-C*    1. Initialization
-C        --------------
-C
-c     WRITE (UNIT = nulou,FMT = *) ' '
-c     WRITE (UNIT = nulou,FMT = *) ' '
-c     WRITE (UNIT = nulou,FMT = *) 
-c    $    '           ROUTINE locread  -  Level 0'
-c     WRITE (UNIT = nulou,FMT = *) 
-c    $    '           ***************     *******'
-c     WRITE (UNIT = nulou,FMT = *) ' '
-c     WRITE (UNIT = nulou,FMT = 1001) knulre
-c     WRITE (UNIT = nulou,FMT = *) ' '
-C
-C* Formats
-C
- 1001 FORMAT(5X,' Read binary file connected to unit = ',I3)
-C
-C     2. Find field in file
-C        ------------------
-C
-      REWIND knulre
- 200  CONTINUE
-C* Find string
-      READ (UNIT = knulre, ERR = 210, END = 210) clecfl
-      IF (clecfl .NE. cdfldn) GO TO  200
-C* Read associated field
-      READ (UNIT = knulre, ERR = 210, END = 210) pfield
-C* Reading done and ok
-      kflgre = 0
-      GO TO 220
-C* Problem in reading
- 210  kflgre = 1
- 220  CONTINUE
-C
-C
-C*    3. End of routine
-C        --------------
-C
-c     WRITE (UNIT = nulou,FMT = *) 
-c    $    '          --------- End of routine locread ---------'
-c     WRITE (UNIT = nulou,FMT = *) ' '
-c     CALL FLUSH (nulou)
-      RETURN
-      END
-
-
-      SUBROUTINE intocpl(itau,imjm,
-     .                   fsol, fnsol,
-     .                   rain, snow, evap, ruisoce, ruisriv,
-     .                   tsol, fder, albe,
-     .                   taux, tauy)
+
+
+      IF (cchan.eq.'CLIM') THEN 
+
+c
+c     -Get interpolated oceanic fields from Oasis
+c
+          DO jf=1,jpfldo2a
+            IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
+            IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info)
+            IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info)
+            IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info)
+            IF ( info .NE. CLIM_Ok) THEN
+                WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
+                WRITE(nuout,*)'Couplage kt is = ',kt
+                WRITE(nuout,*)'CLIM error code is = ', info
+                CALL halte('STOP in fromcpl.F')
+            ENDIF
+          END DO 
+
+      ENDIF 
+c
+      RETURN
+      END
+
+c $Id$
+      SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat,
+     $    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff,
+     $    tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v,last) 
+c ======================================================================
+c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the 
+c atmospheric coupling fields to the coupler with the CLIM (PVM exchange 
+c messages) technique. 
+c IF last time step, writes output fields to binary files.
+c ======================================================================
       IMPLICIT NONE
-c
-c Laurent Z.X Li (Feb. 10, 1997): It provides several fields to the
-c coupler. Of course, it sends a message to the corresponding pipes
-c after the writting.
-c
-      INTEGER itau, imjm
-c
-      REAL fsol(imjm)
-      REAL fnsol(imjm)
-      REAL rain(imjm)
-      REAL snow(imjm)
-      REAL evap(imjm)
-      REAL ruisoce(imjm)
-      REAL ruisriv(imjm)
-      REAL tsol(imjm)
-      REAL fder(imjm)
-      REAL albe(imjm)
-      REAL taux(imjm)
-      REAL tauy(imjm)
+      INTEGER kt, imjm
+c
+      REAL fsolice(imjm)
+      REAL fsolwat(imjm)
+      REAL fnsolwat(imjm)
+      REAL fnsolice(imjm) 
+      REAL fnsicedt(imjm) 
+      REAL evice(imjm)
+      REAL evwat(imjm)
+      REAL lpre(imjm)
+      REAL spre(imjm)
+      REAL dirunoff(imjm)
+      REAL rivrunoff(imjm)
+c$$$      REAL tauxu(imjm)
+c$$$      REAL tauxv(imjm)
+c$$$      REAL tauyu(imjm)
+c$$$      REAL tauyv(imjm)
+      REAL tauxx_u(imjm)
+      REAL tauxx_v(imjm)
+      REAL tauyy_u(imjm)
+      REAL tauyy_v(imjm)
+      REAL tauzz_u(imjm)
+      REAL tauzz_v(imjm)
+      LOGICAL last
 c
       INTEGER nuout
       PARAMETER (nuout = 6)
-C
-      INTEGER nuwrit, ios
-      CHARACTER*8 pipnom
-      CHARACTER*8 fldnom
-      CHARACTER*8 filnom
-c
-c
-#include "oasis.h"
-#include "clim.h"
-      INTEGER info
-      INTEGER isize, iret
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Intocpl: send fields to CPL, itau= ", itau
-      WRITE(nuout,*) " "
-c
-      IF (cchain.EQ."PIPE") THEN
-c
-      nuwrit = 99
-      filnom = "atmflx"
-      OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(6,*) "Error while connecting "//filnom
-          CALL ABORT('STOP in intocpl')
-      ENDIF
-      REWIND ( UNIT = nuwrit)
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Writting fields to "//filnom, nuwrit
-      WRITE(nuout,*) " "
-      CALL flush(nuout)
-C
-C            ecriture CONSFTOT (flux non solaire)
-C
-      fldnom = "CONSFTOT"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) fnsol
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COSHFTOT (solaire)
-C
-      fldnom = "COSHFTOT"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) fsol
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COTOLPSU (precipitation liquide)
-C
-      fldnom = "COTOLPSU"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) rain
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COTOSPSU (precipitation solide)
-C
-      fldnom = "COTOSPSU"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) snow
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COTFSHSU (evaporation)
-C
-      fldnom = "COTFSHSU"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) evap
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COSSTSST (temperature du sol)
-C
-      fldnom = "COSSTSST"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) tsol
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture CODFLXDT (derivee du flux non-solaire)
-C
-      fldnom = "CODFLXDT"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) fder
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture COALBSUR (albedo moyen)
-C
-      fldnom = "COALBSUR"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) albe
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture CORUNCOA (runoff DIRECT)
-C
-      fldnom = "CORUNCOA"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) ruisoce
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C           ecriture river runoff 'CORIVFLU'
-C
-      fldnom = "CORIVFLU"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) ruisriv
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-c
-      CLOSE(UNIT = nuwrit)
-C
-C simulate a FLUSH
-C
-      OPEN(nuwrit, FILE=filnom, FORM='unformatted')
-      CLOSE(UNIT = nuwrit)
-C
-C Send message to pipes:
-c
-      pipnom = 'Consftot'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Coshftot'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cotolpsu'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cotospsu'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cotfshsu'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cosstsst'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Codflxdt'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Coalbsur'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Coruncoa'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Corivflu'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-C
-C Send wind stresses to coupler
-c
-      nuwrit = 99
-      filnom = "atmtau"
-      OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios)
-      IF (ios .NE. 0) THEN
-          WRITE(6,*) "Error while connecting "//filnom
-          CALL ABORT('STOP in intocpl')
-      ENDIF
-      REWIND ( UNIT = nuwrit)
-c
-      WRITE(nuout,*) " "
-      WRITE(nuout,*) "Writting fields to "//filnom, nuwrit
-      WRITE(nuout,*) " "
-C
-C ecriture COZOTAUX
-c
-      fldnom = "COZOTAUX"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) taux
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-c
-      fldnom = "COZOTAU2"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) taux
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-C
-C ecriture COMETAUY
-C
-      fldnom = "COMETAUY"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) tauy
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-c
-      fldnom = "COMETAU2"
-      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
-      WRITE(UNIT = nuwrit) tauy
-      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
-c
-      CLOSE(UNIT = nuwrit)
-C
-C simulate a FLUSH
-C
-      OPEN(nuwrit, FILE=filnom, FORM='unformatted')
-      CLOSE(UNIT = nuwrit)
-c
-c Send message to pipes:
-c
-      pipnom = 'Cozotaux'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cozotau2'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cometauy'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      pipnom = 'Cometau2'
-#ifdef CRAY
-      WRITE(pipnom) itau
-#else
-      isize=1
-      iret=0
-      CALL pipwrite(pipnom,itau,isize,iret)
-#endif
-      WRITE(nuout,*) "Message sent to pipe "//pipnom
-c
-      ELSE ! cchain.EQ."CLIM"
-c
-      CALL CLIM_Export("CONSFTOT", itau, fnsol, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export fnsol pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COSHFTOT", itau, fsol, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export fsol pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COTOLPSU", itau, rain, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export rain pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COTOSPSU", itau, snow, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export snow pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COTFSHSU", itau, evap, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export evap pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COSSTSST", itau, tsol, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export tsol pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("CODFLXDT", itau, fder, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COALBSUR", itau, albe, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("CORUNCOA", itau, ruisoce, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export ruisoce pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("CORIVFLU", itau, ruisriv, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export ruisriv pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COZOTAUX", itau, taux, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COZOTAU2", itau, taux, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COMETAUY", itau, tauy, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      CALL CLIM_Export("COMETAU2", itau, tauy, info)
-      IF (info .NE. CLIM_Ok) THEN
-         WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info
-         CALL ABORT("STOP in intocpl")
-      ENDIF
-c
-      ENDIF
-c
-      RETURN
-      END
+c
+      INCLUDE 'clim.h'
+      INCLUDE 'param_cou.h'
+      INCLUDE 'inc_cpl.h'
+c
+      CHARACTER*8 file_name(jpmaxfld)
+      INTEGER max_file
+      INTEGER file_unit_max, file_unit(jpmaxfld),
+     $    file_unit_field(jpmaxfld) 
+
+      INTEGER icstep, info, jn, jf, ierror
+      LOGICAL trouve
+c
+      INCLUDE 'oasis.h'
+c
+      icstep=kt 
+c
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
+      WRITE(nuout,*) ' '
+
+      IF (last) THEN 
+c
+c     -WRITE fields to binary files for coupler restart at last time step
+c
+c         -initialisation and files opening
+c
+          max_file=1
+          file_unit_max=99
+c         -keeps first file name
+          file_name(max_file)=cl_f_writ(max_file)
+c         -keeps first file unit
+          file_unit(max_file)=file_unit_max
+c         -decrements file unit maximum
+          file_unit_max=file_unit_max-1
+c         -keeps file unit for field
+          file_unit_field(1)=file_unit(max_file)
+c
+c         -different files names counter
+c
+          DO jf= 2, jpflda2o1 + jpflda2o2
+            trouve=.false.
+            DO jn= 1, max_file
+              IF (.not.trouve) THEN
+                  IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
+c                 -keep file unit for field
+                      file_unit_field(jf)=file_unit(jn)
+                      trouve=.true.
+                  END IF 
+              END IF 
+            END DO 
+            IF (.not.trouve) then
+c           -increment the number of different files
+                max_file=max_file+1
+c           -keep file name
+                file_name(max_file)=cl_f_writ(jf)
+c           -keep file unit for file
+                file_unit(max_file)=file_unit_max
+c           -keep file unit for field
+                file_unit_field(jf)=file_unit(max_file)
+c           -decrement unit maximum number from 99 to 98, ...
+                file_unit_max=file_unit_max-1
+            END IF 
+          END DO 
+c          
+          DO jn=1, max_file 
+            OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
+          END DO
+c 
+c         WRITE fields to files          
+          DO jf=1, jpflda2o1 + jpflda2o2
+            IF (jf.eq.1)
+     $          CALL locwrite(cl_writ(jf),fsolice, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.2)
+     $          CALL locwrite(cl_writ(jf),fsolwat, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.3)
+     $          CALL locwrite(cl_writ(jf),fnsolice, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.4)
+     $          CALL locwrite(cl_writ(jf),fnsolwat, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.5)
+     $          CALL locwrite(cl_writ(jf),fnsicedt, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+c            IF (jf.eq.6)
+c     $          CALL locwrite(cl_writ(jf),ictemp, imjm,
+c     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.6)
+     $          CALL locwrite(cl_writ(jf),evice, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.7)
+     $          CALL locwrite(cl_writ(jf),evwat, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.8)
+     $          CALL locwrite(cl_writ(jf),lpre, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.9)
+     $          CALL locwrite(cl_writ(jf),spre, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.10)
+     $          CALL locwrite(cl_writ(jf),dirunoff, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.11)
+     $          CALL locwrite(cl_writ(jf),rivrunoff, imjm,
+     $          file_unit_field(jf), ierror, nuout) 
+c$$$            IF (jf.eq.12)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
+c$$$     $          file_unit_field(jf),ierror, nuout) 
+c$$$            IF (jf.eq.13)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
+c$$$     $          file_unit_field(jf),ierror, nuout) 
+c$$$            IF (jf.eq.14)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
+c$$$     $          file_unit_field(jf),ierror, nuout) 
+c$$$            IF (jf.eq.15)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
+c$$$     $          file_unit_field(jf), ierror, nuout) 
+            IF (jf.eq.12)
+     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.13)
+     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.14)
+     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.15)
+     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.16)
+     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.17)
+     $          CALL locwrite(cl_writ(jf),tauzz_v, imjm,
+     $          file_unit_field(jf),ierror)
+          END DO 
+C
+C         -simulate a FLUSH
+C
+          DO jn=1, max_file 
+            CLOSE (file_unit(jn))
+          END DO 
+C
+C
+          IF(cchan.eq.'CLIM') THEN 
+C
+C         -inform PVM daemon that message exchange is finished
+C
+              CALL CLIM_Quit (CLIM_ContPvm, info)
+              IF (info .NE. CLIM_Ok) THEN
+                  WRITE (6, *) 
+     $                'An error occured while leaving CLIM. Error = ',
+     $                info
+              ENDIF
+          END IF 
+          RETURN    
+      END IF 
+C
+      IF(cchan.eq.'CLIM') THEN 
+C
+C     -Give atmospheric fields to Oasis
+C 
+          DO jn=1, jpflda2o1 + jpflda2o2
+C            
+          IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info)
+          IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info)
+          IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info)
+          IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info)
+          IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info)
+c          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info)
+          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, evice, info)
+          IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, evwat, info)
+          IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, lpre, info)
+          IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, spre, info)
+          IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info)
+          IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info)
+c$$$          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
+c$$$          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
+c$$$          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
+c$$$          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
+          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
+          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
+          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
+          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
+          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
+          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info)
+          
+            IF (info .NE. CLIM_Ok) THEN
+                WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
+                WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
+                WRITE (nuout,*) 'Clim error code is = ',info
+                CALL halte('STOP in intocpl ')
+            ENDIF
+          END DO 
+      ENDIF 
+C
+      RETURN
+      END
+
+      SUBROUTINE halte
+      print *, 'Attention dans oasis.F, halte est non defini'
+      RETURN
+      END
+
+      SUBROUTINE locread
+      print *, 'Attention dans oasis.F, locread est non defini'
+      RETURN
+      END
+
+      SUBROUTINE locwrite
+      print *, 'Attention dans oasis.F, locwrite est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_define
+      print*,'Attention dans oasis.F, pipe_model_define est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_stepi
+      print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_recv
+      print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_send
+      print *, 'Attention dans oasis.F, pipe_model_send est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_stepi
+      print *, 'Attention dans oasis.F, clim_stepi est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_start
+      print *, 'Attention dans oasis.F, clim_start est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_import
+      print *, 'Attention dans oasis.F, clim_import est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_export
+      print *, 'Attention dans oasis.F, clim_export est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_init
+      print *, 'Attention dans oasis.F, clim_init est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_define
+      print *, 'Attention dans oasis.F, clim_define est non defini'
+      RETURN
+      END
+
+      SUBROUTINE clim_quit
+      print *, 'Attention dans oasis.F, clim_quit est non defini'
+      RETURN
+      END
+
+      SUBROUTINE svipc_write
+      print *, 'Attention dans oasis.F, svipc_write est non defini'
+      RETURN
+      END
+
+      SUBROUTINE svipc_close
+      print *, 'Attention dans oasis.F, svipc_close est non defini'
+      RETURN
+      END
+
+      SUBROUTINE svipc_read
+      print *, 'Attention dans oasis.F, svipc_read est non defini'
+      RETURN
+      END
+
       SUBROUTINE quitcpl
-      IMPLICIT none
-c
-c Sortir du coupleur
-c
-      INTEGER nuout   ! listing output unit
-      PARAMETER (nuout=6)
-c
-#include "oasis.h"
-#include "clim.h"
-      INTEGER info
-c
-      IF (cchain.EQ."PIPE") THEN
-c
-         WRITE(nuout,*)"On sort du coupleur sans rien faire"
-c
-      ELSE ! cchain.EQ."CLIM"
-c
-         CALL CLIM_Quit(CLIM_StopPvm,info)
-         IF (info.NE.CLIM_Ok) THEN
-            WRITE(nuout,*)"Erreur pour quiter coupleur:",info
-         ENDIF
-c
-      ENDIF
-c
-      RETURN
-      END
-
-
-      SUBROUTINE makepipe
-      PRINT*, "rien"
-      END
-      SUBROUTINE pipwrite
-      PRINT*, "rien"
-      END
-      SUBROUTINE pipread
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Init
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Define
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Start
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Stepi
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Import
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_Export
-      PRINT*, "rien"
-      END
-      SUBROUTINE CLIM_quit
-      PRINT*, "rien"
-      END
+      print *, 'Attention dans oasis.F, quitcpl est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_write_model
+      print *, 'Attention dans oasis.F, sipc_write_model est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_attach
+      print *, 'Attention dans oasis.F, sipc_attach est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_init_model
+      print *, 'Attention dans oasis.F, sipc_init_model est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_read_model
+      print *, 'Attention dans oasis.F, sipc_read_model est non defini'
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/oasis.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.h	(revision 300)
@@ -1,6 +1,14 @@
-      LOGICAL ok_oasis
-      PARAMETER (ok_oasis = .FALSE.)
-c
-      CHARACTER*8 cchain
-      PARAMETER (cchain="PIPE")
-c      PARAMETER (cchain="CLIM")
+C
+C -- oasis.h   
+C    ******
+C@
+C@  Contents : choice for the OASIS version: clim or pipe
+C@  --------
+
+      logical ok_oasis
+      parameter(ok_oasis = .false.)
+
+      CHARACTER*8 cchan
+      PARAMETER ( cchan='CLIM' )
+C
+C     --- end of oasis.h
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.true
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.true	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/oasis.true	(revision 300)
@@ -0,0 +1,587 @@
+C $Id$
+C****
+C
+C**** *INICMA*  - Initialize coupled mode communication for atmosphere
+C                 and exchange some initial information with Oasis
+C
+C     Input:
+C     -----
+C       KASTP  : total number of timesteps in atmospheric model
+C       KEXCH  : frequency of exchange (in time steps)
+C       KSTEP  : length of timestep (in seconds)
+C
+C     -----------------------------------------------------------
+C
+      SUBROUTINE inicma(kastp,kexch,kstep,imjm)
+c
+c     INCLUDE 'param.h'
+c
+      INTEGER kastp, kexch, kstep,imjm
+      INTEGER iparal(3)
+      INTEGER ifcpl, idt, info, imxtag, istep, jf
+c
+      INCLUDE 'param_cou.h'
+      INCLUDE 'inc_cpl.h'
+      CHARACTER*3 cljobnam      ! experiment name
+      CHARACTER*6 clmodnam      ! model name
+c     EM: not used by Oasis2.4
+CEM      CHARACTER*6 clbid(2)      ! for CLIM_Init call (not used)
+CEM                                ! must be dimensioned by the number of models
+CEM      INTEGER nbid(2)           ! for CLIM_Init call (not used)
+CEM                                ! must be dimensioned by the number of models
+      CHARACTER*5 cloasis       ! coupler name (Oasis)
+      INTEGER imess(4)
+      INTEGER getpid            ! system functions
+      INTEGER nuout
+CEM      LOGICAL llmodel
+      PARAMETER (nuout = 6)
+c
+      INCLUDE 'clim.h'
+      INCLUDE 'mpiclim.h'
+c
+      INCLUDE 'oasis.h' ! contains the name of communication technique. Here
+                        ! cchan=CLIM only is possible.
+c			! ctype=MPI2
+c
+C     -----------------------------------------------------------
+C
+C*    1. Initializations
+C        ---------------
+C
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' ROUTINE INICMA'
+      WRITE(nuout,*) ' **************'
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' '
+c
+c     Define the model name
+c
+      clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+c
+c     Define the coupler name
+c
+      cloasis = 'Oasis'        !  always 'Oasis' as in the coupler
+c
+c
+c     Define symbolic name for fields exchanged from atmos to coupler,
+c         must be the same as (1) of the field  definition in namcouple:
+c
+      cl_writ(1)='COSHFICE'
+      cl_writ(2)='COSHFOCE'
+      cl_writ(3)='CONSFICE'
+      cl_writ(4)='CONSFOCE'
+      cl_writ(5)='CODFLXDT'
+c      cl_writ(6)='COICTEMP'
+      cl_writ(6)='COTFSICE'
+      cl_writ(7)='COTFSOCE'
+      cl_writ(8)='COTOLPSU'
+      cl_writ(9)='COTOSPSU'
+      cl_writ(10)='CORUNCOA'
+      cl_writ(11)='CORIVFLU'
+c$$$      cl_writ(12)='COZOTAUX'
+c$$$      cl_writ(13)='COZOTAUV'
+c$$$      cl_writ(14)='COMETAUY'
+c$$$      cl_writ(15)='COMETAUU'
+      cl_writ(12)='COTAUXXU'
+      cl_writ(13)='COTAUYYU'
+      cl_writ(14)='COTAUZZU'
+      cl_writ(15)='COTAUXXV'
+      cl_writ(16)='COTAUYYV'
+      cl_writ(17)='COTAUZZV'
+c
+c     Define files name for fields exchanged from atmos to coupler,
+c         must be the same as (6) of the field  definition in namcouple:
+c
+      cl_f_writ(1)='flxatmos'
+      cl_f_writ(2)='flxatmos'
+      cl_f_writ(3)='flxatmos'
+      cl_f_writ(4)='flxatmos'
+      cl_f_writ(5)='flxatmos'
+      cl_f_writ(6)='flxatmos'
+      cl_f_writ(7)='flxatmos'
+      cl_f_writ(8)='flxatmos'
+      cl_f_writ(9)='flxatmos'
+      cl_f_writ(10)='flxatmos'
+      cl_f_writ(11)='flxatmos'
+      cl_f_writ(12)='flxatmos'
+      cl_f_writ(13)='flxatmos'
+      cl_f_writ(14)='flxatmos'
+      cl_f_writ(15)='flxatmos'
+      cl_f_writ(16)='flxatmos'
+      cl_f_writ(17)='flxatmos'
+
+c
+c
+c     Define symbolic name for fields exchanged from coupler to atmosphere,
+c         must be the same as (2) of the field  definition in namcouple:
+c
+      cl_read(1)='SISUTESW'
+      cl_read(2)='SIICECOV'
+      cl_read(3)='SIICEALW'
+      cl_read(4)='SIICTEMW'
+c
+c     Define files names for fields exchanged from coupler to atmosphere,
+c         must be the same as (7) of the field  definition in namcouple:
+c
+      cl_f_read(1)='sstatmos'
+      cl_f_read(2)='sstatmos'
+      cl_f_read(3)='sstatmos'
+      cl_f_read(4)='sstatmos'
+c
+c
+c     Define the number of processors involved in the coupling for
+c     Oasis (=1) and each model (as last two INTEGER on $CHATYPE line
+c     in the namcouple); they will be stored in a COMMON in mpiclim.h
+c     (used for CLIM/MPI2 only)
+      mpi_nproc(0)=1
+      mpi_nproc(1)=1
+      mpi_nproc(2)=1 
+c
+c     Define infos to be sent initially to oasis
+c
+      imess(1) = kastp      ! total number of timesteps in atmospheric model
+      imess(2) = kexch      ! period of exchange (in time steps)
+      imess(3) = kstep      ! length of atmospheric timestep (in seconds)
+      imess(4) = getpid()   ! PID of atmospheric model
+c
+c     Initialization and exchange of initial info in the CLIM technique
+c
+      IF (cchan.eq.'CLIM') THEN
+c
+c     Define the experiment name :
+c
+          cljobnam = 'CLI'      ! as $JOBNAM in namcouple
+c
+c         Start the coupling 
+c         (see lib/clim/src/CLIM_Init for the definition of input parameters)
+c
+cEM          clbid(1)='      '
+cEM          clbid(2)='      '
+cEM          nbid(1)=0
+cEM          nbid(2)=0
+CEM          llmodel=.true.
+c
+c         Define the number of processors used by each model as in
+c         $CHATYPE line of namcouple (used for CLIM/MPI2 only) 
+          mpi_totproc(1)=1
+          mpi_totproc(2)=1
+c
+c         Define names of each model as in $NBMODEL line of namcouple
+c         (used for CLIM/MPI2 only)        
+          cmpi_modnam(1)='lmdz.x'
+          cmpi_modnam(2)='opa.xx'
+c         Start the coupling 
+c
+          CALL CLIM_Init ( cljobnam, clmodnam, 3, 7,
+     *                 kastp, kexch, kstep,
+     *                 5, 3600, 3600, info )
+c
+          IF (info.ne.CLIM_Ok) THEN
+              WRITE ( nuout, *) ' inicma : pb init clim '
+              WRITE ( nuout, *) ' error code is = ', info
+              CALL halte('STOP in inicma')
+            ELSE
+              WRITE(nuout,*) 'inicma : init clim ok '
+          ENDIF
+c
+c         For each coupling field, association of a port to its symbolic name
+c
+c         -Define the parallel decomposition associated to the port of each
+c          field; here no decomposition for all ports.
+          iparal ( clim_strategy ) = clim_serial 
+          iparal ( clim_length   ) = imjm
+          iparal ( clim_offset   ) = 0
+c
+c         -Loop on total number of coupler-to-atmosphere fields
+c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
+          DO jf=1, jpfldo2a
+            CALL CLIM_Define (cl_read(jf), clim_in , clim_double, iparal
+     $          , info )  
+            WRITE(nuout,*) 'inicma : clim define done for ',jf
+     $          ,cl_read(jf) 
+          END DO 
+c
+c         -Loop on total number of atmosphere-to-coupler fields 
+c         (see lib/clim/src/CLIM_Define for the definition of input parameters)
+          DO jf=1, jpflda2o1+jpflda2o2
+            CALL CLIM_Define (cl_writ(jf), clim_out , clim_double,
+     $          iparal, info )   
+            WRITE(nuout,*) 'inicma : clim define done for ',jf
+     $          ,cl_writ(jf) 
+          END DO 
+c
+          WRITE(nuout,*) 'inicma : clim_define ok '
+c
+c         -Join a pvm group, wait for other programs and broadcast usefull 
+c          informations to Oasis and to the ocean (see lib/clim/src/CLIM_Start)
+          CALL CLIM_Start ( imxtag, info )
+          IF (info.ne.clim_ok) THEN
+              WRITE ( nuout, *) 'inicma : pb start clim '
+              WRITE ( nuout, *) ' error code is = ', info
+              CALL halte('stop in inicma')
+            ELSE
+              WRITE ( nuout, *)  'inicma : start clim ok '
+          ENDIF
+c
+c         -Get initial information from Oasis
+c          (see lib/clim/src/CLIM_Stepi)
+          CALL CLIM_Stepi (cloasis, istep, ifcpl, idt, info)
+          IF (info .NE. clim_ok) THEN
+              WRITE ( UNIT = nuout, FMT = *)
+     $            ' warning : problem in getting step info ',
+     $            'from oasis '
+              WRITE (UNIT = nuout, FMT = *)
+     $            ' =======   error code number = ', info
+            ELSE
+              WRITE (UNIT = nuout, FMT = *)
+     $            ' got step information from oasis '
+          ENDIF
+          WRITE ( nuout, *) ' number of tstep in oasis ', istep
+          WRITE ( nuout, *) ' exchange frequency in oasis ', ifcpl
+          WRITE ( nuout, *) ' length of tstep in oasis ', idt
+      ENDIF 
+
+      RETURN
+      END
+
+c $Id$
+      SUBROUTINE fromcpl(kt, imjm, sst, gla, tice, albedo)
+c ======================================================================
+c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine reads the SST 
+c and Sea-Ice provided by the coupler with the CLIM (PVM exchange messages)
+c technique. 
+c======================================================================
+      IMPLICIT none
+      INTEGER imjm, kt
+      REAL sst(imjm)          ! sea-surface-temperature
+      REAL gla(imjm)          ! sea-ice
+      REAL tice(imjm)          ! temp glace
+      REAL albedo(imjm)          ! albedo glace
+c
+      INTEGER nuout             ! listing output unit
+      PARAMETER (nuout=6)
+c
+      INTEGER nuread, ios, iflag, icpliter
+      INTEGER info, jf
+c
+      INCLUDE 'clim.h'
+c
+      INCLUDE 'oasis.h'
+      INCLUDE 'param_cou.h'
+c
+      INCLUDE 'inc_cpl.h'
+c
+c
+      WRITE (nuout,*) ' '
+      WRITE (nuout,*) 'Fromcpl: Reading fields from CPL, kt=',kt
+      WRITE (nuout,*) ' '
+      CALL flush (nuout)
+
+
+      IF (cchan.eq.'CLIM') THEN 
+
+c
+c     -Get interpolated oceanic fields from Oasis
+c
+          DO jf=1,jpfldo2a
+            IF (jf.eq.1) CALL CLIM_Import (cl_read(jf) , kt, sst, info)
+            IF (jf.eq.2) CALL CLIM_Import (cl_read(jf) , kt, gla, info)
+            IF (jf.eq.3) CALL CLIM_Import (cl_read(jf), kt,albedo, info)
+            IF (jf.eq.4) CALL CLIM_Import (cl_read(jf) , kt, tice, info)
+            IF ( info .NE. CLIM_Ok) THEN
+                WRITE(nuout,*)'Pb in reading ', cl_read(jf), jf
+                WRITE(nuout,*)'Couplage kt is = ',kt
+                WRITE(nuout,*)'CLIM error code is = ', info
+                CALL halte('STOP in fromcpl.F')
+            ENDIF
+          END DO 
+
+      ENDIF 
+c
+      RETURN
+      END
+
+c $Id$
+      SUBROUTINE intocpl(kt, imjm, fsolice, fsolwat, fnsolice, fnsolwat,
+     $    fnsicedt, evice, evwat, lpre, spre, dirunoff, rivrunoff,
+     $    tauxx_u, tauyy_u, tauzz_u, tauxx_v, tauyy_v, tauzz_v,last) 
+c ======================================================================
+c S. Valcke (02/99) adapted From L.Z.X Li: this subroutine provides the 
+c atmospheric coupling fields to the coupler with the CLIM (PVM exchange 
+c messages) technique. 
+c IF last time step, writes output fields to binary files.
+c ======================================================================
+      IMPLICIT NONE
+      INTEGER kt, imjm
+c
+      REAL fsolice(imjm)
+      REAL fsolwat(imjm)
+      REAL fnsolwat(imjm)
+      REAL fnsolice(imjm) 
+      REAL fnsicedt(imjm) 
+      REAL evice(imjm)
+      REAL evwat(imjm)
+      REAL lpre(imjm)
+      REAL spre(imjm)
+      REAL dirunoff(imjm)
+      REAL rivrunoff(imjm)
+c$$$      REAL tauxu(imjm)
+c$$$      REAL tauxv(imjm)
+c$$$      REAL tauyu(imjm)
+c$$$      REAL tauyv(imjm)
+      REAL tauxx_u(imjm)
+      REAL tauxx_v(imjm)
+      REAL tauyy_u(imjm)
+      REAL tauyy_v(imjm)
+      REAL tauzz_u(imjm)
+      REAL tauzz_v(imjm)
+      LOGICAL last
+c
+      INTEGER nuout
+      PARAMETER (nuout = 6)
+c
+      INCLUDE 'clim.h'
+      INCLUDE 'param_cou.h'
+      INCLUDE 'inc_cpl.h'
+c
+      CHARACTER*8 file_name(jpmaxfld)
+      INTEGER max_file
+      INTEGER file_unit_max, file_unit(jpmaxfld),
+     $    file_unit_field(jpmaxfld) 
+
+      INTEGER icstep, info, jn, jf, ierror
+      LOGICAL trouve
+c
+      INCLUDE 'oasis.h'
+c
+      icstep=kt 
+c
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) 'Intocpl: sending fields to CPL, kt= ', kt
+      WRITE(nuout,*) ' '
+
+      IF (last) THEN 
+c
+c     -WRITE fields to binary files for coupler restart at last time step
+c
+c         -initialisation and files opening
+c
+          max_file=1
+          file_unit_max=99
+c         -keeps first file name
+          file_name(max_file)=cl_f_writ(max_file)
+c         -keeps first file unit
+          file_unit(max_file)=file_unit_max
+c         -decrements file unit maximum
+          file_unit_max=file_unit_max-1
+c         -keeps file unit for field
+          file_unit_field(1)=file_unit(max_file)
+c
+c         -different files names counter
+c
+          DO jf= 2, jpflda2o1 + jpflda2o2
+            trouve=.false.
+            DO jn= 1, max_file
+              IF (.not.trouve) THEN
+                  IF (cl_f_writ(jf).EQ.file_name(jn)) THEN
+c                 -keep file unit for field
+                      file_unit_field(jf)=file_unit(jn)
+                      trouve=.true.
+                  END IF 
+              END IF 
+            END DO 
+            IF (.not.trouve) then
+c           -increment the number of different files
+                max_file=max_file+1
+c           -keep file name
+                file_name(max_file)=cl_f_writ(jf)
+c           -keep file unit for file
+                file_unit(max_file)=file_unit_max
+c           -keep file unit for field
+                file_unit_field(jf)=file_unit(max_file)
+c           -decrement unit maximum number from 99 to 98, ...
+                file_unit_max=file_unit_max-1
+            END IF 
+          END DO 
+c          
+          DO jn=1, max_file 
+            OPEN (file_unit(jn), FILE=file_name(jn), FORM='UNFORMATTED')
+          END DO
+c 
+c         WRITE fields to files          
+          DO jf=1, jpflda2o1 + jpflda2o2
+            IF (jf.eq.1)
+     $          CALL locwrite(cl_writ(jf),fsolice, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.2)
+     $          CALL locwrite(cl_writ(jf),fsolwat, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.3)
+     $          CALL locwrite(cl_writ(jf),fnsolice, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.4)
+     $          CALL locwrite(cl_writ(jf),fnsolwat, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.5)
+     $          CALL locwrite(cl_writ(jf),fnsicedt, imjm,
+     $          file_unit_field(jf), ierror) 
+c            IF (jf.eq.6)
+c     $          CALL locwrite(cl_writ(jf),ictemp, imjm,
+c     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.6)
+     $          CALL locwrite(cl_writ(jf),evice, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.7)
+     $          CALL locwrite(cl_writ(jf),evwat, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.8)
+     $          CALL locwrite(cl_writ(jf),lpre, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.9)
+     $          CALL locwrite(cl_writ(jf),spre, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.10)
+     $          CALL locwrite(cl_writ(jf),dirunoff, imjm,
+     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.11)
+     $          CALL locwrite(cl_writ(jf),rivrunoff, imjm,
+     $          file_unit_field(jf), ierror) 
+c$$$            IF (jf.eq.12)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.13)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.14)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.15)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
+c$$$     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.12)
+     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.13)
+     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.14)
+     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.15)
+     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.16)
+     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.17)
+     $          CALL locwrite(cl_writ(jf),tauzz_v, imjm,
+     $          file_unit_field(jf),ierror)
+          END DO 
+C
+C         -simulate a FLUSH
+C
+          DO jn=1, max_file 
+            CLOSE (file_unit(jn))
+          END DO 
+C
+C
+          IF(cchan.eq.'CLIM') THEN 
+C
+C         -inform PVM daemon that message exchange is finished
+C
+              CALL CLIM_Quit (CLIM_ContPvm, info)
+              IF (info .NE. CLIM_Ok) THEN
+                  WRITE (6, *) 
+     $                'An error occured while leaving CLIM. Error = ',
+     $                info
+              ENDIF
+          END IF 
+          RETURN    
+      END IF 
+C
+      IF(cchan.eq.'CLIM') THEN 
+C
+C     -Give atmospheric fields to Oasis
+C 
+          DO jn=1, jpflda2o1 + jpflda2o2
+C            
+          IF (jn.eq.1) CALL CLIM_Export(cl_writ(jn), kt, fsolice, info)
+          IF (jn.eq.2) CALL CLIM_Export(cl_writ(jn), kt, fsolwat, info)
+          IF (jn.eq.3) CALL CLIM_Export(cl_writ(jn), kt, fnsolice, info)
+          IF (jn.eq.4) CALL CLIM_Export(cl_writ(jn), kt, fnsolwat, info)
+          IF (jn.eq.5) CALL CLIM_Export(cl_writ(jn), kt, fnsicedt, info)
+c          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, ictemp, info)
+          IF (jn.eq.6) CALL CLIM_Export(cl_writ(jn), kt, evice, info)
+          IF (jn.eq.7) CALL CLIM_Export(cl_writ(jn), kt, evwat, info)
+          IF (jn.eq.8) CALL CLIM_Export(cl_writ(jn), kt, lpre, info)
+          IF (jn.eq.9) CALL CLIM_Export(cl_writ(jn), kt, spre, info)
+          IF (jn.eq.10) CALL CLIM_Export(cl_writ(jn),kt,dirunoff, info)
+          IF (jn.eq.11) CALL CLIM_Export(cl_writ(jn),kt,rivrunoff,info)
+c$$$          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
+c$$$          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
+c$$$          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
+c$$$          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
+          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
+          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
+          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
+          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
+          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
+          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauzz_v, info)
+          
+            IF (info .NE. CLIM_Ok) THEN
+                WRITE (nuout,*) 'STEP : Pb giving ',cl_writ(jn), ':',jn
+                WRITE (nuout,*) ' at timestep = ', icstep,'kt = ',kt
+                WRITE (nuout,*) 'Clim error code is = ',info
+                CALL halte('STOP in intocpl ')
+            ENDIF
+          END DO 
+      ENDIF 
+C
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_define
+      print*,'Attention dans oasis.F, pipe_model_define est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_stepi
+      print*,'Attention dans oasis.F, pipe_model_stepi est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_recv
+      print *, 'Attention dans oasis.F, pipe_model_recv est non defini'
+      RETURN
+      END
+
+      SUBROUTINE pipe_model_send
+      print *, 'Attention dans oasis.F, pipe_model_send est non defini'
+      RETURN
+      END
+
+      SUBROUTINE quitcpl
+      print *, 'Attention dans oasis.F, quitcpl est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_write_model
+      print *, 'Attention dans oasis.F, sipc_write_model est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_attach
+      print *, 'Attention dans oasis.F, sipc_attach est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_init_model
+      print *, 'Attention dans oasis.F, sipc_init_model est non defini'
+      RETURN
+      END
+
+      SUBROUTINE sipc_read_model
+      print *, 'Attention dans oasis.F, sipc_read_model est non defini'
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/orografi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/orografi.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/orografi.F	(revision 300)
@@ -1,5 +1,5 @@
       SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
      e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
-     e                   kgwd,kgwdim,kdx,ktest,
+     e                   kgwd,kdx,ktest,
      e                   t, u, v,
      s                   pulow, pvlow, pustr, pvstr,
@@ -39,5 +39,5 @@
       REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
 c
-      INTEGER i, k, kgwd, kgwdim, kdx(nlon), ktest(nlon)
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
 c
 c Variables locales:
@@ -96,5 +96,5 @@
 c appeler la routine principale
 c
-      CALL orodrag(klon,klev,kgwd,kgwdim,kdx,ktest,
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
      .            dtime,
      .            papmh, papmf, zgeom,
@@ -119,5 +119,5 @@
       END
       SUBROUTINE orodrag( nlon,nlev 
-     i                 , kgwd, kgwdim, kdx, ktest
+     i                 , kgwd, kdx, ktest
      r                 , ptsphy
      r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
@@ -126,4 +126,7 @@
      r                 , pulow,pvlow
      r                 , pvom,pvol,pte )
+
+      implicit none
+
 c
 c
@@ -152,5 +155,5 @@
 c        --------------------
 c
-      implicit logical (l)
+c      implicit logical (l)
 c
 c     method.
@@ -183,4 +186,9 @@
 c
 c
+      integer nlon, nlev, klevm1
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
       real  pte(nlon,nlev),
      *      pvol(nlon,nlev),
@@ -212,4 +220,5 @@
 c
       real   ztau(klon,klev+1),
+     $       ztauf(klon,klev+1),
      *       zstab(klon,klev+1),
      *       zvph(klon,klev+1),
@@ -223,9 +232,9 @@
      *       zdedt(klon),
      *       zvidis(klon),
-     *       ztfr(klon),
      *       znu(klon),
      *       zd1(klon),
      *       zd2(klon),
      *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
 c
 c------------------------------------------------------------------
@@ -272,6 +281,6 @@
 c
       call orosetup
-     *     ( nlon, nlev , ktest 
-     *     , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
      *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
      *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
@@ -292,8 +301,8 @@
       call gwstress
      *    ( nlon  , nlev
-     *    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu
-     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval
-     *    , ztfr   , ztau 
-     *    , pgeom1,pgamma,zd1,zd2,zdmod,znu)
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
 c
 c
@@ -306,10 +315,9 @@
       call gwprofil
      *       (  nlon , nlev
-     *       , kgwd   , kdx  , ktest
-     *       , ikcrit, ikcrith, icrit  , ikenvh, iknu
-     *       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph
-     *       , zri   , ztau   , ztauf
-c
-     *       , zdmod , znu    , psig  , pgamma , pstd , ppic , pval)
+     *       , kgwd   , kdx
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
 c
 c
@@ -401,6 +409,6 @@
       end
       SUBROUTINE orosetup
-     *         ( nlon   , nlev  , ktest
-     *         , kkcrit, kkcrith, kcrit, ksect , kkhlim
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
      *         , kkenvh, kknu  , kknu2
      *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
@@ -448,5 +456,5 @@
 c
 c-----------------------------------------------------------------------
-      implicit logical (l)
+      implicit none
 c
 
@@ -461,6 +469,10 @@
 c              ---------
 c
-      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
-     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon)
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
 
 c
@@ -480,4 +492,10 @@
 c
 c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
       logical ll1(klon,klev+1)
       integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
@@ -486,5 +504,5 @@
       real zhcrit(klon,klev),zvpf(klon,klev),
      *     zdp(klon,klev)
-      real znorm(klon),zpsi(klon),zb(klon),zc(klon),
+      real znorm(klon),zb(klon),zc(klon),
      *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
 c
@@ -862,9 +880,9 @@
       SUBROUTINE gwstress
      *         (  nlon  , nlev
-     *         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh
+     *         , ktest, kcrit, kkenvh
      *         , kknu
      *         , prho  , pstab , pvph  , pstd, psig
-     *         , pmea , ppic , pval  , ptfr  , ptau  
-     *         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
 c
 c**** *gwstress*
@@ -906,5 +924,5 @@
 c
 c-----------------------------------------------------------------------
-      implicit logical (l)
+      implicit none
 #include "dimensions.h"
 #include "dimphy.h"
@@ -917,13 +935,14 @@
 c              ---------
 c
-      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
-     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+      integer nlon, nlev
+      integer kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon),kknu(nlon)
 c
       real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
-     *     pvph(nlon,nlev+1),ptfr(nlon),
+     *     pvph(nlon,nlev+1),
      *     pgeom1(nlon,nlev),pstd(nlon)
 c
-      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
-      real pmea(nlon),ppic(nlon),pval(nlon)
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
       real pdmod(nlon)
 c
@@ -932,4 +951,7 @@
 c*       0.2   local arrays
 c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
 c
 c-----------------------------------------------------------------------
@@ -985,8 +1007,8 @@
       SUBROUTINE GWPROFIL
      *         ( NLON, NLEV
-     *         , kgwd ,kdx  , ktest
-     *         , KKCRIT, KKCRITH, KCRIT ,  kkenvh, kknu,kknu2
-     *         , PAPHM1, PRHO   , PSTAB , PTFR , PVPH , PRI , PTAU
-     *         , ptauf ,pdmod   , pnu   , psig ,pgamma, pvar, ppic,pval)
+     *         , kgwd, kdx
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
 
 C**** *GWPROFIL*
@@ -1036,5 +1058,5 @@
 C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
 C-----------------------------------------------------------------------
-      IMPLICIT LOGICAL (L)
+      implicit none
 C
 
@@ -1051,15 +1073,14 @@
 C              ---------
 C
-      INTEGER KKCRIT(NLON),KKCRITH(NLON),KCRIT(NLON)
-     *       ,kdx(nlon),ktest(NLON)
-     *       ,kkenvh(NLON),kknu(NLON),kknu2(NLON)
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon)
 C
       REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
      *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
-     *     PRI   (NLON,NLEV+1), PTFR (NLON), PTAU(NLON,NLEV+1),
-     *     ptauf (NLON,nlev+1)
+     *     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)
      
-      REAL pdmod (NLON) , pnu (NLON) , psig(NLON),
-     *     pgamma(NLON) , pvar(NLON) , ppic(NLON), pval(NLON)
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
      
 C-----------------------------------------------------------------------
@@ -1068,4 +1089,7 @@
 C              ------------
 C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
       REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
       REAL ZTAU (KLON,KLEV+1)
@@ -1221,6 +1245,6 @@
       END
       SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
-     e                   plat,pmea,pstd, psig, pgam, pthe, ppic,pval,
-     e                   kgwd,kgwdim,kdx,ktest,
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
      e                   t, u, v,
      s                   pulow, pvlow, pustr, pvstr,
@@ -1255,11 +1279,11 @@
       REAL pplay(klon,klev)
       REAL plat(nlon),pmea(nlon)
-      REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
-      REAL ppic(nlon),pval(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
       REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
       REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
       REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
 c
-      INTEGER i, k, kgwd, kgwdim, kdx(nlon), ktest(nlon)
+      INTEGER i, k, ktest(nlon)
 c
 c Variables locales:
@@ -1318,9 +1342,9 @@
 c appeler la routine principale
 c
-      CALL OROLIFT(klon,klev,kgwd,kgwdim,kdx,ktest,
+      CALL OROLIFT(klon,klev,ktest,
      .            dtime,
-     .            papmh, papmf, zgeom,
+     .            papmh, zgeom,
      .            pt, pu, pv,
-     .            plat,pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            plat,pmea, pstd, ppic,
      .            pulow,pvlow,
      .            pdudt,pdvdt,pdtdt)
@@ -1341,9 +1365,9 @@
       END
       SUBROUTINE OROLIFT( NLON,NLEV
-     I                 , KGWD, KGWDIM, KDX, KTEST
+     I                 , KTEST
      R                 , PTSPHY
-     R                 , PAPHM1,PAPM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
      R                 , PLAT
-     R                 , PMEA, PVAROR, PSIG, PGAMMA, PTHETA,ppic,pval
+     R                 , PMEA, PVAROR, ppic
 C OUTPUTS
      R                 , PULOW,PVLOW
@@ -1365,5 +1389,5 @@
 C     F.LOTT  LMD 22/11/95
 C
-      IMPLICIT LOGICAL (L)
+      implicit none
 C
 C
@@ -1378,4 +1402,5 @@
 C
 C
+      integer nlon, nlev
       REAL  PTE(NLON,NLEV),
      *      PVOL(NLON,NLEV),
@@ -1387,43 +1412,29 @@
      *      PTM1(NLON,NLEV),
      *      PLAT(NLON),PMEA(NLON),
-     *      PVAROR(NLON),PSIG(NLON),PGAMMA(NLON),
-     *      PTHETA(NLON),ppic(NLON),pval(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
      *      PGEOM1(NLON,NLEV),
-     *      PAPM1(NLON,NLEV),
      *      PAPHM1(NLON,NLEV+1)
 C
-      INTEGER  KDX(NLON),KTEST(NLON)
+      INTEGER  KTEST(NLON)
+      real ptsphy
 C-----------------------------------------------------------------------
 C
 C*       0.2   LOCAL ARRAYS
 C              ------------
-      INTEGER  ISECT(KLON),
-     *         ICRIT(KLON),
-     *         IKCRITH(KLON),
-     *         IKenvh(klon),
+      logical lifthigh, ll1
+      integer klevm1, jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER  
      *         IKNUB(klon),
-     *         IKNUL(klon),
-     *         IKCRIT(KLON),
-     *         IKHLIM(KLON)
+     *         IKNUL(klon)
       LOGICAL LL1(KLON,KLEV+1)
 C
       REAL   ZTAU(KLON,KLEV+1),
      *       ZTAV(KLON,KLEV+1),
-     *       ZSTAB(KLON,KLEV+1),
-     *       ZVPH(KLON,KLEV+1),
-     *       ZRHO(KLON,KLEV+1),
-     *       ZRI(KLON,KLEV+1),
-     *       ZpsI(KLON,KLEV+1),
-     *       Zzdep(KLON,KLEV)
+     *       ZRHO(KLON,KLEV+1)
       REAL   ZDUDT(KLON),
-     *       ZDVDT(KLON),
-     *       ZDTDT(KLON),
-     *       ZDEDT(KLON),
-     *       ZVIDIS(KLON),
-     *       ZTFR(KLON),
-     *       Znu(KLON),
-     *       Zd1(KLON),
-     *       Zd2(KLON),
-     *       Zdmod(KLON)
+     *       ZDVDT(KLON)
       REAL ZHCRIT(KLON,KLEV)
 C-----------------------------------------------------------------------
@@ -1680,5 +1691,5 @@
 C        ORIGINAL : 90-01-01
 C     ------------------------------------------------------------------
-      IMPLICIT LOGICAL(L)
+      implicit none
 C
 C     -----------------------------------------------------------------
@@ -1686,7 +1697,8 @@
 C      ----------------------------------------------------------------
 C
-      integer nlon,nlev
+      integer nlon,nlev, jk
       REAL paprs(nlon,nlev+1)
       REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
 C
 C*       1.    SET THE VALUES OF THE PARAMETERS
@@ -1724,5 +1736,5 @@
 C
       GKDRAG=0.2 
-      GRAHILO=1    
+      GRAHILO=1.    
       GRCRIT=0.01
       GFRCRIT=1.0
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_cou.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_cou.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_cou.h	(revision 300)
@@ -0,0 +1,18 @@
+! $Id$
+!
+! -- param_cou.h
+!
+	INTEGER jpmaxfld
+	PARAMETER(jpmaxfld = 40)        ! Maximum number of fields exchanged
+                                        ! between ocean and atmosphere
+	INTEGER jpflda2o1
+	PARAMETER(jpflda2o1 = 11)         ! Number of fields exchanged from
+                                         ! atmosphere to ocean via flx.F
+	INTEGER jpflda2o2
+	PARAMETER(jpflda2o2 = 6)         ! Number of fields exchanged from
+                                         ! atmosphere to ocean via tau.F
+!
+	INTEGER jpfldo2a
+	PARAMETER(jpfldo2a = 4)          ! Number of fields exchanged from
+                                         ! ocean to atmosphere
+!
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_sipc.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_sipc.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/param_sipc.h	(revision 300)
@@ -0,0 +1,21 @@
+C@
+C@ -- param_sipc.h
+C@
+C@ -- jpbyteint : number of bytes per integer
+C@
+C@ -- jpbyterea : number of bytes per real
+C@
+C@ -- jpbytecha : number of bytes per character
+C@
+	INTEGER jpbyteint,jpbyterea, jpbytecha  
+        PARAMETER (jpbyteint = 4)
+	PARAMETER (jpbyterea = 8)
+	PARAMETER (jpbytecha = 1)
+C@
+C@ -- jptest :  The models will test during 2*jptest seconds if the file 
+C@              DUMMY_SIPC has been created by OASIS, signaling that the
+C@              SHM pools are opened. After, they will abort.
+C@
+        INTEGER jptest
+        PARAMETER(jptest = 100)      
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/phyetat0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phyetat0.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/phyetat0.F	(revision 300)
@@ -1,6 +1,8 @@
       SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm,solaire,
-     .            rlat,rlon,tsol,tsoil,deltat,qsol,snow,
-     .           radsol,rugmer,agesno,clesphy0,
-     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,tabcntr0)
+     .            rlat,rlon, pctsrf, tsol,tsoil,deltat,qsol,snow,
+     .           albe, evap, rain_fall, snow_fall, solsw, sollw,
+     .           fder,radsol,frugs,agesno,clesphy0,
+     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,tabcntr0,
+     .           t_ancien,q_ancien,ancien_ok)
       IMPLICIT none
 c======================================================================
@@ -26,6 +28,13 @@
       REAL qsol(klon,nbsrf)
       REAL snow(klon,nbsrf)
+      REAL albe(klon,nbsrf)
+      REAL evap(klon,nbsrf)
       REAL radsol(klon)
-      REAL rugmer(klon)
+      REAL rain_fall(klon)
+      REAL snow_fall(klon)
+      REAL sollw(klon)
+      real solsw(klon)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
       REAL agesno(klon)
       REAL zmea(klon)
@@ -37,4 +46,9 @@
       REAL zval(klon)
       REAL rugsrel(klon)
+      REAL pctsrf(klon, nbsrf)
+      REAL fractint(klon)
+
+      REAL t_ancien(klon,klev), q_ancien(klon,klev)
+      LOGICAL ancien_ok
 
       INTEGER        longcles
@@ -54,4 +68,5 @@
 c Ouvrir le fichier contenant l'etat initial:
 c
+      print*,'fichnom',fichnom
       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
       IF (ierr.NE.NF_NOERR) THEN
@@ -180,5 +195,123 @@
          CALL abort
       ENDIF
-c
+C
+C
+C Lecture du masque terre mer
+C
+      ierr = NF_INQ_VARID (nid, "masque", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmasq)
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, zmasq)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <masque>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <masque> est absent'
+          PRINT*, 'fichier startphy non compatible avec phyetat0'
+C      CALL abort
+      ENDIF
+C Lecture des fractions pour chaque sous-surface
+C
+C initialisation des sous-surfaces
+C
+      pctsrf = 0.
+C
+C fraction de terre
+C
+      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_ter))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_ter))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FTER>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FTER> est absent'
+c$$$         CALL abort
+      ENDIF
+C
+C fraction de glace de terre
+C
+      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_lic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_lic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FLIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+c$$$         CALL abort
+      ENDIF
+C
+C fraction d'ocean
+C
+      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_oce))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon,is_oce))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FOCE>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+c$$$         CALL abort
+      ENDIF
+C
+C fraction glace de mer
+C
+      ierr = NF_INQ_VARID (nid, "FSIC", nvarid)
+      IF (ierr .EQ.  NF_NOERR) THEN
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, pctsrf(1 : klon,is_sic))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, pctsrf(1 : klon, is_sic))
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, 'phyetat0: Lecture echouee pour <FSIC>'
+              CALL abort
+          ENDIF
+      else
+          PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+c$$$         CALL abort
+      ENDIF
+C
+C  Verification de l'adequation entre le masque et les sous-surfaces
+C
+      fractint( 1 : klon) = pctsrf(1 : klon, is_ter) 
+     $    + pctsrf(1 : klon, is_lic)
+      DO i = 1 , klon
+        IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
+     $          'coherente ', i, zmasq(i), pctsrf(i, is_ter)
+     $          ,pctsrf(i, is_lic)
+        ENDIF 
+      END DO 
+      fractint (1 : klon) =  pctsrf(1 : klon, is_oce) 
+     $    + pctsrf(1 : klon, is_sic)
+      DO i = 1 , klon
+        IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
+     $          'coherente ', i, zmasq(i) , pctsrf(i, is_oce)
+     $          ,pctsrf(i, is_sic)
+        ENDIF 
+      END DO 
+C
 c Lecture des temperatures du sol:
 c
@@ -415,4 +548,253 @@
       ENDIF
 c
+c Lecture de albedo au sol:
+c
+      ierr = NF_INQ_VARID (nid, "ALBE", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ALBE> est absent'
+         PRINT*, '          Mais je vais essayer de lire ALBE**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "ALBE"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <ALBE"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <ALBE"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(albe(i,nsrf),xmin)
+              xmax = MAX(albe(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBE> est present'
+         PRINT*, '          J ignore donc les autres ALBE**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <ALBE>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(albe(i,1),xmin)
+            xmax = MAX(albe(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            albe(i,nsrf) = albe(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de evaporation:  
+c
+      ierr = NF_INQ_VARID (nid, "EVAP", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <EVAP> est absent'
+         PRINT*, '          Mais je vais essayer de lire EVAP**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "EVAP"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <EVAP"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <EVAP"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(evap(i,nsrf),xmin)
+              xmax = MAX(evap(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'evap du sol EVAP**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <EVAP> est present'
+         PRINT*, '          J ignore donc les autres EVAP**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, evap(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, evap(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <EVAP>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(evap(i,1),xmin)
+            xmax = MAX(evap(i,1),xmax)
+         ENDDO
+         PRINT*,'Evap du sol <EVAP>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture precipitation liquide:
+c
+      ierr = NF_INQ_VARID (nid, "rain_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <rain_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rain_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rain_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <rain_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+c
+c Lecture precipitation solide:
+c
+      ierr = NF_INQ_VARID (nid, "snow_f", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <snow_f> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow_fall)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, snow_fall)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <snow_f>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+c
+c Lecture rayonnement solaire au sol:
+c
+      ierr = NF_INQ_VARID (nid, "solsw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, solsw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <solsw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+c
+c Lecture rayonnement IF au sol:
+c
+      ierr = NF_INQ_VARID (nid, "sollw", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, sollw)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <sollw>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+
+c
+c Lecture derive des flux:
+c
+      ierr = NF_INQ_VARID (nid, "fder", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ELSE
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, fder)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <fder>'
+          CALL abort
+        ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+c
 c Lecture du rayonnement net au sol:
 c
@@ -439,27 +821,65 @@
       PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
 c
-c Lecture de la longueur de rugosite en mer:
-c
-      ierr = NF_INQ_VARID (nid, "RUGMER", nvarid)
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Le champ <RUGMER> est absent'
-         CALL abort
-      ENDIF
-#ifdef NC_DOUBLE
-      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugmer)
-#else
-      ierr = NF_GET_VAR_REAL(nid, nvarid, rugmer)
-#endif
-      IF (ierr.NE.NF_NOERR) THEN
-         PRINT*, 'phyetat0: Lecture echouee pour <RUGMER>'
-         CALL abort
-      ENDIF
-      xmin = 1.0E+20
-      xmax = -1.0E+20
-      DO i = 1, klon
-         xmin = MIN(rugmer(i),xmin)
-         xmax = MAX(rugmer(i),xmax)
-      ENDDO
-      PRINT*,'Rugosite sur la mer rugmer:', xmin, xmax
+c Lecture de la longueur de rugosite 
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUG> est absent'
+         PRINT*, '          Mais je vais essayer de lire RUG**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           ierr = NF_INQ_VARID (nid, "RUG"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <RUG"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <RUG"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(frugs(i,nsrf),xmin)
+              xmax = MAX(frugs(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'rugosite du sol RUG**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <RUG> est present'
+         PRINT*, '          J ignore donc les autres RUG**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, frugs(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, frugs(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RUG>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(frugs(i,1),xmin)
+            xmax = MAX(frugs(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <RUG>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
 c
 c Lecture de l'age de la neige:
@@ -674,4 +1094,41 @@
       PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
 c
+c
+      ancien_ok = .TRUE.
+c
+      ierr = NF_INQ_VARID (nid, "TANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, t_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, t_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "QANCIEN", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_ancien)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, q_ancien)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QANCIEN>"
+            CALL abort
+         ENDIF
+      ENDIF
+c
 c Fermer le fichier:
 c
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/phyredem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phyredem.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/phyredem.F	(revision 300)
@@ -1,6 +1,11 @@
+c $Header$
+c
       SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire,
-     .           rlat,rlon,tsol,tsoil,deltat,qsol,snow,
-     .           radsol,rugmer,agesno,
-     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel)
+     .           rlat,rlon, pctsrf,tsol,tsoil,deltat,qsol,snow,
+     .           albedo, evap, rain_fall, snow_fall,
+     .           solsw, sollw,fder,
+     .           radsol,frugs,agesno,
+     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,
+     .           t_ancien, q_ancien)
       IMPLICIT none
 c======================================================================
@@ -15,4 +20,5 @@
 #include "clesphys.h"
 #include "control.h"
+#include "temps.h"
 c======================================================================
       CHARACTER*(*) fichnom
@@ -27,7 +33,14 @@
       REAL qsol(klon,nbsrf)
       REAL snow(klon,nbsrf)
+      REAL albedo(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      REAL rain_fall(klon)
+      REAL snow_fall(klon)
+      real solsw(klon)
+      real sollw(klon)
+      real fder(klon)
       REAL radsol(klon)
-      REAL rugmer(klon)
-      REAL agesno(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
       REAL zmea(klon)
       REAL zstd(klon)
@@ -38,6 +51,8 @@
       REAL zval(klon)
       REAL rugsrel(klon)
-c
-      INTEGER nid, nvarid, idim1, idim2
+      REAL pctsrf(klon, nbsrf)
+      REAL t_ancien(klon,klev), q_ancien(klon,klev)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
       INTEGER ierr
       INTEGER length
@@ -61,4 +76,5 @@
       ierr = NF_DEF_DIM (nid, "index", length, idim1)
       ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2)
+      ierr = NF_DEF_DIM (nid, "horizon_vertical", klon*klev, idim3)
 c
       ierr = NF_ENDDEF(nid)
@@ -82,11 +98,9 @@
       tab_cntrl(13) = dayref
       tab_cntrl(14) = anneeref
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
-#else
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = anne_ini
+c
+      ierr = NF_REDEF (nid)
       ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
      .                        "Parametres de controle")
@@ -99,9 +113,5 @@
 c
       ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid)
-#else
       ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
      .                        "Longitudes de la grille physique")
@@ -114,9 +124,5 @@
 c
       ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid)
-#else
       ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31,
      .                        "Latitudes de la grille physique")
@@ -128,4 +134,71 @@
 #endif
 c
+C PB ajout du masque terre/mer
+C
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "masque", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 16,
+     .                        "masque terre mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmasq)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmasq)
+#endif      
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "fraction de continent")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_ter))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_ter))
+#endif
+C 
+C 2. Fraction de glace de terre
+C 
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24,
+     .                        "fraction glace de terre")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon,is_lic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_lic))
+#endif
+C
+C 3. fraction ocean
+C
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "fraction ocean")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_oce))
+#endif
+C
+C 4. Fraction glace de mer
+C
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                        "fraction glace mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pctsrf(1 : klon, is_sic))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pctsrf(1 : klon, is_sic))
+#endif
+C
+C
 c
       DO nsrf = 1, nbsrf
@@ -133,9 +206,5 @@
         WRITE(str2,'(i2.2)') nsrf
         ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid)
-#else
         ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid)
-#endif
         ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
      .                        "Temperature de surface No."//str2)
@@ -157,9 +226,5 @@
         WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
         ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid)
-#else
         ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid)
-#endif
         ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29,
      .                        "Temperature du sol No."//str7)
@@ -179,9 +244,5 @@
 c
       ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid)
-#else
       ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
      .                        "Ecart de la SST (pour slab-ocean)")
@@ -197,9 +258,5 @@
         WRITE(str2,'(i2.2)') nsrf
         ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
         ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
         ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
      .                        "Humidite de surface No."//str2)
@@ -220,9 +277,44 @@
         WRITE(str2,'(i2.2)') nsrf
         ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-        ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid)
-#else
+        ierr = NF_DEF_VAR (nid,"ALBE"//str2,NF_FLOAT,1,idim2,nvarid)
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "albedo de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+        ierr = NF_DEF_VAR (nid,"EVAP"//str2,NF_FLOAT,1,idim2,nvarid)
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Evaporation de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,evap(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,evap(1,nsrf))
+#endif
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
         ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid)
-#endif
         ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
      .                        "Neige de surface No."//str2)
@@ -238,11 +330,8 @@
 #endif
       ENDDO
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
-#else
+
+c
+      ierr = NF_REDEF (nid)
       ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
      .                        "Rayonnement net a la surface")
@@ -255,136 +344,198 @@
 c
       ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
-#else
+      ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32,
+     .                        "Rayonnement solaire a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27,
+     .                        "Rayonnement IF a la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14,
+     .                        "Derive de flux")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,fder)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "rain_f", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                        "precipitation liquide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rain_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rain_fall)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "snow_f", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                        "precipitation solide")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow_fall)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,snow_fall)
+#endif
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+        ierr = NF_REDEF (nid)
+        ierr = NF_DEF_VAR (nid,"RUG"//str2,NF_FLOAT,1,idim2,nvarid)
+        ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 23,
+     .                        "rugosite de surface No."//str2)
+        ierr = NF_ENDDEF(nid)
+        ELSE
+        PRINT*, "Trop de sous-mailles"
+        CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,nsrf))
+#endif
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            ierr = NF_REDEF (nid)
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
+     $          ,nvarid)
+            ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige surface No."//str2)
+            ierr = NF_ENDDEF(nid)
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno(1,nsrf))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno(1,nsrf))
+#endif
+      ENDDO
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien)
+#endif
+c
+      ierr = NF_REDEF (nid)
       ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
-#endif
       ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
      .                        "Longueur de rugosite sur mer")
       ierr = NF_ENDDEF(nid)
 #ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "AGESNO", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "AGESNO", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
-     .                        "Age de la neige")
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
-#endif
-c
-      ierr = NF_REDEF (nid)
-#ifdef NC_DOUBLE
-      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
-#else
-      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
-#endif
-      ierr = NF_ENDDEF(nid)
-#ifdef NC_DOUBLE
-      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
-#else
-      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
-#endif
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,frugs(1,is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
+#endif
+c
 c
       ierr = NF_CLOSE(nid)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/physiq.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/physiq.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/physiq.F	(revision 300)
@@ -1,10 +1,15 @@
+c
+c $Header$
+c
       SUBROUTINE physiq (nlon,nlev,nqmax  ,
      .            debut,lafin,rjourvrai,rjour_ecri,gmtime,pdtphys,
      .            paprs,pplay,pphi,pphis,paire,presnivs,clesphy0,
      .            u,v,t,qx,
-     .            d_u_dyn, d_v_dyn,  d_t_dyn, d_qx_dyn,
-     .            omega,
+     .            omega, cufi, cvfi,
      .            d_u, d_v, d_t, d_qx, d_ps)
       USE ioipsl
+      USE histcom
+      USE writephys
+
       IMPLICIT none
 c======================================================================
@@ -40,9 +45,9 @@
 c t-------input-R-temperature (K)
 c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
-c d_u_dyn-input-R-tendance dynamique pour "u" (m/s/s)
-c d_v_dyn-input-R-tendance dynamique pour "v" (m/s/s)
 c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
-c d_qx_dyn-input-R-tendance dynamique pour "qx" (kg/kg/s)
+c d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
 c omega---input-R-vitesse verticale en Pa/s
+c cufi----input-R-resolution des mailles en x (m)
+c cvfi----input-R-resolution des mailles en y (m)
 c
 c d_u-----output-R-tendance physique de "u" (m/s/s)
@@ -53,4 +58,6 @@
 c======================================================================
 #include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
 #include "dimphy.h"
 #include "regdim.h"
@@ -59,31 +66,26 @@
 #include "clesphys.h"
 #include "control.h"
+#include "temps.h"
 c======================================================================
       LOGICAL check ! Verifier la conservation du modele en eau
       PARAMETER (check=.FALSE.)
+      LOGICAL ok_stratus ! Ajouter artificiellement les stratus
+      PARAMETER (ok_stratus=.FALSE.)
 c======================================================================
 c Parametres lies au coupleur OASIS:
 #include "oasis.h"
-      INTEGER npas, nexca, itimestep
+      INTEGER,SAVE :: npas, nexca
       logical rnpb
       parameter(rnpb=.true.)
-      PARAMETER (npas=1440)
-      PARAMETER (nexca=48)
-      PARAMETER (itimestep=1800)
-      EXTERNAL intocpl, inicma
-c======================================================================
-c ok_ocean indique l'utilisation du modele oceanique "slab ocean",
-c il faut bien sur s'assurer que le bilan energetique de reference
-c a la surface de l'ocean est bien present dans le fichier des
-c conditions aux limites, ainsi que l'indicateur du sol ne contient
-c pas de glace oceanique (pas de valeur 3).
-c
-      LOGICAL ok_ocean
-      PARAMETER (ok_ocean=.FALSE.)
-      REAL cyang  ! capacite thermique de l'ocean superficiel
-      PARAMETER (cyang=30.0 * 4.228e+06)
-      REAL cbing  ! capacite thermique de la glace oceanique
-      PARAMETER (cbing=1.0 * 4.228e+06)
-      REAL cthermiq
+c      PARAMETER (npas=1440)
+c      PARAMETER (nexca=48)
+      EXTERNAL fromcpl, intocpl, inicma
+c      ocean = type de modele ocean a utiliser: force, slab, couple
+      character*6 ocean
+      SAVE ocean
+
+c      parameter (ocean = 'force ')
+c     parameter (ocean = 'couple')
+      logical ok_ocean
 c======================================================================
 c Clef controlant l'activation du cycle diurne:
@@ -94,6 +96,8 @@
 ccc      LOGICAL soil_model
 ccc      PARAMETER (soil_model=.FALSE.)
-      REAL soilcap(klon,nbsrf), soilflux(klon,nbsrf)
-      SAVE soilcap, soilflux
+      logical ok_veget
+      save ok_veget
+c     parameter (ok_veget = .true.)
+c      parameter (ok_veget = .false.)
 c======================================================================
 c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
@@ -112,11 +116,14 @@
 c======================================================================
       LOGICAL ok_journe ! sortir le fichier journalier
-      PARAMETER (ok_journe=.FALSE.)
+      save ok_journe
+c      PARAMETER (ok_journe=.true.)
 c
       LOGICAL ok_mensuel ! sortir le fichier mensuel
-      PARAMETER (ok_mensuel=.TRUE.)
+      save ok_mensuel
+c      PARAMETER (ok_mensuel=.true.)
 c
       LOGICAL ok_instan ! sortir le fichier instantane
-      PARAMETER (ok_instan=.FALSE.)
+      save ok_instan
+c      PARAMETER (ok_instan=.true.)
 c
       LOGICAL ok_region ! sortir le fichier regional
@@ -128,9 +135,11 @@
       INTEGER iliq          ! indice de traceurs pour eau liquide
       PARAMETER (iliq=2)
-c
+
       INTEGER nvm           ! nombre de vegetations
       PARAMETER (nvm=8)
       REAL veget(klon,nvm)  ! couverture vegetale
       SAVE veget
+
+c
 c
 c Variables argument:
@@ -150,4 +159,6 @@
       REAL presnivs(klev)
       REAL znivsig(klev)
+      REAL zsurf(nbsrf)
+      real cufi(klon), cvfi(klon)
 
       REAL u(klon,klev)
@@ -156,8 +167,11 @@
       REAL qx(klon,klev,nqmax)
 
-      REAL d_u_dyn(klon,klev)
-      REAL d_v_dyn(klon,klev)
+      REAL t_ancien(klon,klev), q_ancien(klon,klev)
+      SAVE t_ancien, q_ancien
+      LOGICAL ancien_ok
+      SAVE ancien_ok
+
       REAL d_t_dyn(klon,klev)
-      REAL d_qx_dyn(klon,klev,2)
+      REAL d_q_dyn(klon,klev)
 
       REAL omega(klon,klev)
@@ -214,4 +228,9 @@
       SAVE ftsoil                 ! temperature dans le sol
 c
+      REAL fevap(klon,nbsrf)
+      SAVE fevap                 ! evaporation
+      REAL fluxlat(klon,nbsrf)
+      SAVE fluxlat
+c
       REAL deltat(klon)
       SAVE deltat                 ! ecart avec la SST de reference
@@ -223,6 +242,10 @@
       SAVE fsnow                  ! epaisseur neigeuse
 c
-      REAL rugmer(klon)
-      SAVE rugmer                 ! longeur de rugosite sur mer (m)
+      REAL falbe(klon,nbsrf)
+      SAVE falbe                  ! albedo par type de surface
+      REAL falblw(klon,nbsrf)
+      SAVE falblw                 ! albedo par type de surface
+
+c
 c
 c  Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
@@ -257,11 +280,40 @@
       SAVE zuthe
       SAVE zvthe
-      INTEGER igwd,igwdim,idx(klon),itest(klon)
-c
-      REAL agesno(klon)
+      INTEGER igwd,idx(klon),itest(klon)
+c
+      REAL agesno(klon,nbsrf)
       SAVE agesno                 ! age de la neige
 c
       REAL alb_neig(klon)
       SAVE alb_neig               ! albedo de la neige
+cKE43
+c Variables liees a la convection de K. Emanuel (sb):
+c
+      REAL ema_workcbmf(klon)   ! cloud base mass flux
+      SAVE ema_workcbmf
+
+      REAL ema_cbmf(klon)       ! cloud base mass flux
+      SAVE ema_cbmf
+
+      REAL ema_pcb(klon)        ! cloud base pressure
+      SAVE ema_pcb
+
+      REAL ema_pct(klon)        ! cloud top pressure
+      SAVE ema_pct
+
+      REAL bas, top             ! cloud base and top levels
+      SAVE bas
+      SAVE top
+
+      REAL Ma(klon,klev)        ! undilute upward mass flux
+      SAVE Ma
+      REAL ema_work1(klon, klev), ema_work2(klon, klev)
+      SAVE ema_work1, ema_work2
+      REAL wdn(klon), tdn(klon), qdn(klon)
+c Variables locales pour la couche limite (al1):
+c
+cAl1      REAL pblh(klon)           ! Hauteur de couche limite
+cAl1      SAVE pblh
+c34EK
 c
 c Variables locales:
@@ -276,5 +328,6 @@
       REAL yv1(klon)            ! vents dans la premiere couche V
       LOGICAL offline           ! Controle du stockage ds "physique"
-      PARAMETER (offline=.TRUE.)
+      PARAMETER (offline=.false.)
+      INTEGER physid
       REAL pfrac_impa(klon,klev)! Produits des coefs lessivage impaction
       save pfrac_impa
@@ -288,9 +341,11 @@
       REAL rain_fall(klon) ! pluie
       REAL snow_fall(klon) ! neige
+      save snow_fall, rain_fall
       REAL evap(klon), devap(klon) ! evaporation et sa derivee
       REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+      REAL dlw(klon)    ! derivee infra rouge
       REAL bils(klon) ! bilan de chaleur au sol
       REAL fder(klon) ! Derive de flux (sensible et latente) 
-      REAL ruis(klon) ! ruissellement
+      save fder
       REAL ve(klon) ! integr. verticale du transport meri. de l'energie
       REAL vq(klon) ! integr. verticale du transport meri. de l'eau
@@ -299,4 +354,5 @@
 c
       REAL frugs(klon,nbsrf) ! longueur de rugosite
+      save frugs
       REAL zxrugs(klon) ! longueur de rugosite
 c
@@ -311,16 +367,13 @@
       REAL pctsrf(klon,nbsrf)
       SAVE pctsrf                 ! sous-fraction du sol
-      REAL lmt_sst(klon)
-      SAVE lmt_sst                ! temperature de la surface ocean
-      REAL lmt_bils(klon)
-      SAVE lmt_bils               ! bilan de chaleur au sol
-      REAL lmt_alb(klon)
-      SAVE lmt_alb                ! temperature de la surface ocean
-      REAL lmt_rug(klon)
-      SAVE lmt_rug                ! longueur de rugosite
-      REAL alb_eau(klon)
-      SAVE alb_eau                ! albedo sur l'ocean
       REAL albsol(klon)
       SAVE albsol                 ! albedo du sol total
+      REAL albsollw(klon)
+      SAVE albsollw                 ! albedo du sol total
+      REAL albsol1(klon)
+      SAVE albsol1                 ! albedo du sol total
+      REAL albsollw1(klon)
+      SAVE albsollw1                 ! albedo du sol total
+
       REAL wo(klon,klev)
       SAVE wo                     ! ozone
@@ -336,5 +389,6 @@
       EXTERNAL condsurf  ! lire les conditions aux limites
       EXTERNAL conlmd    ! convection (schema LMD)
-      EXTERNAL diagcld   ! nuages diagnostiques
+cKE43
+      EXTERNAL conema  ! convect4.3
       EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
 cAA 
@@ -344,5 +398,4 @@
 cAA
       EXTERNAL hgardfou  ! verifier les temperatures
-      EXTERNAL hydrol    ! hydrologie du sol
       EXTERNAL nuage     ! calculer les proprietes radiatives
       EXTERNAL o3cm      ! initialiser l'ozone
@@ -368,9 +421,15 @@
       REAL cldemi(klon,klev)  ! emissivite infrarouge
 c
-      REAL fluxq(klon,klev)   ! flux turbulent d'humidite
-      REAL fluxt(klon,klev)   ! flux turbulent de chaleur
-      REAL fluxu(klon,klev)   ! flux turbulent de vitesse u
-      REAL fluxv(klon,klev)   ! flux turbulent de vitesse v
-c
+C§§§ PB 
+      REAL fluxq(klon,klev, nbsrf)   ! flux turbulent d'humidite
+      REAL fluxt(klon,klev, nbsrf)   ! flux turbulent de chaleur
+      REAL fluxu(klon,klev, nbsrf)   ! flux turbulent de vitesse u
+      REAL fluxv(klon,klev, nbsrf)   ! flux turbulent de vitesse v
+c
+      REAL zxfluxt(klon, klev)
+      REAL zxfluxq(klon, klev)
+      REAL zxfluxu(klon, klev)
+      REAL zxfluxv(klon, klev)
+C§§§
       REAL heat(klon,klev)    ! chauffage solaire
       REAL heat0(klon,klev)   ! chauffage solaire ciel clair
@@ -378,9 +437,10 @@
       REAL cool0(klon,klev)   ! refroidissement infrarouge ciel clair
       REAL topsw(klon), toplw(klon), solsw(klon), sollw(klon)
+      real sollwdown(klon)    ! downward LW flux at surface
       REAL topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
       REAL albpla(klon)
 c Le rayonnement n'est pas calcule tous les pas, il faut donc
 c                      sauvegarder les sorties du rayonnement
-      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw
+      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
       SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
       INTEGER itaprad
@@ -393,5 +453,4 @@
       REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
 c
-      REAL zx_alb_lic, zx_alb_oce, zx_alb_ter, zx_alb_sic
       REAL zxtsol(klon), zxqsol(klon), zxsnow(klon)
 c
@@ -402,14 +461,44 @@
       CHARACTER*2 iqn
 c
+      REAL qcheck
+      REAL z_avant(klon), z_apres(klon), z_factor(klon)
+      LOGICAL zx_ajustq
+c
       REAL za, zb
-      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
-      INTEGER i, k, iq, ig, j, nsrf, ll
+      REAL zx_t, zx_qs, zdelta, zcor, zlvdcp, zlsdcp
+      INTEGER i, k, iq, nsrf, ll
       REAL t_coup
       PARAMETER (t_coup=234.0)
 c
       REAL zphi(klon,klev)
-      REAL zx_tmp_x(iim), zx_tmp_y(jjm+1)
-      REAL zx_relief(iim,jjm+1)
-      REAL zx_aire(iim,jjm+1)
+      REAL zx_tmp_x(iim), zx_tmp_yjjmp1
+      REAL zx_relief(iim,jjmp1)
+      REAL zx_aire(iim,jjmp1)
+cKE43
+c Variables locales pour la convection de K. Emanuel (sb):
+c
+      REAL upwd(klon,klev)      ! saturated updraft mass flux
+      REAL dnwd(klon,klev)      ! saturated downdraft mass flux
+      REAL dnwd0(klon,klev)     ! unsaturated downdraft mass flux
+      REAL tvp(klon,klev)       ! virtual temp of lifted parcel
+      REAL cape(klon)           ! CAPE
+      SAVE cape
+      REAL pbase(klon)          ! cloud base pressure
+      SAVE pbase
+      REAL bbase(klon)          ! cloud base buoyancy
+      SAVE bbase
+      REAL rflag(klon)          ! flag fonctionnement de convect
+      INTEGER iflagctrl(klon)          ! flag fonctionnement de convect
+c -- convect43:
+      INTEGER ntra              ! nb traceurs pour convect4.3
+      REAL pori_con(klon)    ! pressure at the origin level of lifted parcel
+      REAL plcl_con(klon),dtma_con(klon),dtlcl_con(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+c?     .     condm_con(klon,klev),conda_con(klon,klev),
+c?     .     mr_con(klon,klev),ep_con(klon,klev)
+c?     .    ,sadiab(klon,klev),wadiab(klon,klev)
+c --
+c34EK
 c
 c Variables du changement
@@ -423,5 +512,5 @@
       REAL d_u_con(klon,klev),d_v_con(klon,klev)
       REAL d_t_lsc(klon,klev),d_q_lsc(klon,klev),d_ql_lsc(klon,klev)
-c      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
       REAL d_t_eva(klon,klev),d_q_eva(klon,klev)
       REAL rneb(klon,klev)
@@ -432,4 +521,5 @@
       INTEGER kcbot(klon), kctop(klon), kdtop(klon)
       REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      REAL prfl(klon,klev+1), psfl(klon,klev+1)
 c
       INTEGER ibas_con(klon), itop_con(klon)
@@ -445,4 +535,8 @@
       REAL d_u_lif(klon,klev), d_v_lif(klon,klev)
       REAL d_t_lif(klon,klev)
+
+      REAL ratqs(klon,klev)
+      real zpt_conv(klon,klev)
+
 c
 c Variables liees a l'ecriture de la bande histoire physique
@@ -460,30 +554,4 @@
       SAVE ecrit_reg   ! frequence d'ecriture
 c
-      REAL oas_sols(klon), z_sols(iim,jjm+1)
-      SAVE oas_sols
-      REAL oas_nsol(klon), z_nsol(iim,jjm+1)
-      SAVE oas_nsol
-      REAL oas_rain(klon), z_rain(iim,jjm+1)
-      SAVE oas_rain
-      REAL oas_snow(klon), z_snow(iim,jjm+1)
-      SAVE oas_snow
-      REAL oas_evap(klon), z_evap(iim,jjm+1)
-      SAVE oas_evap
-      REAL oas_ruis(klon), z_ruis(iim,jjm+1)
-      SAVE oas_ruis
-      REAL oas_tsol(klon), z_tsol(iim,jjm+1)
-      SAVE oas_tsol
-      REAL oas_fder(klon), z_fder(iim,jjm+1)
-      SAVE oas_fder
-      REAL oas_albe(klon), z_albe(iim,jjm+1)
-      SAVE oas_albe
-      REAL oas_taux(klon), z_taux(iim,jjm+1)
-      SAVE oas_taux
-      REAL oas_tauy(klon), z_tauy(iim,jjm+1)
-      SAVE oas_tauy
-      REAL oas_ruisoce(klon), z_ruisoce(iim,jjm+1)
-      SAVE oas_ruisoce
-      REAL oas_ruisriv(klon), z_ruisriv(iim,jjm+1)
-      SAVE oas_ruisriv
 c
 c
@@ -496,8 +564,6 @@
       REAL tr_seri(klon,klev,nbtr)
       REAL d_tr(klon,klev,nbtr)
-      REAL source_tr(klon,nbtr)
 
       REAL zx_rh(klon,klev)
-      REAL dtimeday,dtimecri,dtimexp9,fecri_pas,fecri86400,fecritday
 
       INTEGER        length
@@ -505,8 +571,8 @@
       REAL tabcntr0( length       )
 c
-      INTEGER ndex(1)
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
       REAL zx_tmp_fi2d(klon)
-      REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
-      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+      REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
+      REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
 c
       INTEGER nid_day, nid_mth, nid_ins
@@ -514,10 +580,23 @@
 c
       INTEGER nhori, nvert
-      REAL zsto, zout, zjulian
+      REAL zsto, zout
+      real zjulian
+      save zjulian
 
       character*20 modname
       character*80 abort_message
       logical ok_sync
-
+      real date0
+
+C essai writephys
+      integer fid_day, fid_mth, fid_ins
+      parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 
+      integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
+      parameter (prof2d_on = 1, prof3d_on = 2,
+     .           prof2d_av = 3, prof3d_av = 4)
+      character*30 nom_fichier
+      character*10 varname
+      character*40 vartitle
+      character*20 varunits
 c
 c Declaration des constantes et des fonctions thermodynamiques
@@ -536,4 +615,6 @@
          CALL suphec ! initialiser constantes et parametres phys.
       ENDIF
+
+
 c======================================================================
       xjour = rjourvrai
@@ -543,21 +624,11 @@
 c
        IF (debut) THEN
-c
- 
-         IF (ok_oasis) THEN
-            PRINT*, "Attentions! les parametres suivants sont fixes:"
-            PRINT *,'***********************************************'
-            PRINT*, "npas, nexca, itimestep=", npas, nexca, itimestep
-            PRINT*, "Changer-les manuellement s il le faut"
-            PRINT *,'***********************************************'
-            CALL inicma( npas, nexca, itimestep)
-         ENDIF
-c
-         IF (ok_ocean) THEN
-            PRINT*, '************************'
-            PRINT*, 'SLAB OCEAN est active, prenez precautions !'
-            PRINT*, '************************'
-         ENDIF
-c
+
+c
+c appel a la lecture du run.def physique
+c
+         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
+     .                  ok_instan)
+
          DO k = 2, nvm          ! pas de vegetation
             DO i = 1, klon
@@ -570,14 +641,18 @@
          PRINT*, 'Pas de vegetation; desert partout'
 c
+c
 c Initialiser les compteurs:
 c
 
+         frugs = 0.
          itap    = 0
          itaprad = 0
 c
          CALL phyetat0 ("startphy.nc",dtime,co2_ppm,solaire,
-     .         rlat,rlon,ftsol,ftsoil,deltat,fqsol,fsnow,
-     .        radsol,rugmer,agesno,clesphy0,
-     .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0 )
+     .       rlat,rlon,pctsrf, ftsol,ftsoil,deltat,fqsol,fsnow,
+     .       falbe, fevap, rain_fall,snow_fall,solsw, sollwdown,
+     .       dlw,radsol,frugs,agesno,clesphy0,
+     .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0,
+     .       t_ancien, q_ancien, ancien_ok )
 
 c
@@ -612,4 +687,21 @@
          PRINT*, "Clef pour la convection, iflag_con=", iflag_con
 c
+cKE43
+c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.EQ.4) THEN
+
+         PRINT*, "*** Convection de Kerry Emanuel 4.3  "
+         PRINT*, "On va utiliser le melange convectif des traceurs qui"
+         PRINT*, "est calcule dans convect4.3"
+         PRINT*, " !!! penser aux logical flags de phytrac"
+
+          DO i = 1, klon
+           ema_cbmf(i) = 0.
+           ema_pcb(i)  = 0.
+           ema_pct(i)  = 0.
+           ema_workcbmf(i) = 0.
+          ENDDO
+         ENDIF
+c34EK
          IF (ok_orodr) THEN
          DO i=1,klon
@@ -627,11 +719,4 @@
          ENDIF
 c
-         IF (soil_model) THEN
-            DO nsrf = 1, nbsrf
-            CALL soil(dtime, nsrf, fsnow(1,nsrf),
-     .                ftsol(1,nsrf), ftsoil(1,1,nsrf),
-     .                soilcap(1,nsrf), soilflux(1,nsrf))
-            ENDDO
-         ENDIF
 c
          lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
@@ -647,5 +732,7 @@
          ENDIF
 ccc         ecrit_ins = NINT(86400./dtime *0.5)  ! 2 fois par jour
-         ecrit_ins = NINT(86400./dtime *0.25)  ! tous les jours
+ccc         ecrit_ins = NINT(86400./dtime *0.25)  ! 4 fois par jour
+         ecrit_ins = NINT(86400./dtime/48.)  ! a chaque pas de temps
+         ecrit_ins = NINT(86400./dtime/12.)  ! toutes les deux heures
          IF (ok_instan) THEN
          PRINT*, 'La frequence de sortie instant. est de ', ecrit_ins
@@ -655,38 +742,69 @@
          PRINT*, 'La frequence de sortie region est de ', ecrit_reg
          ENDIF
-c
+
+c
+c Initialiser le couplage si necessaire
+c
+      npas = 0
+      nexca = 0
+      if (ocean == 'couple') then
+        npas = itaufin/ iphysiq
+        nexca = 86400 / dtime
+        write(*,*)' ##### Ocean couple #####'
+        write(*,*)' Valeurs des pas de temps'
+        write(*,*)' npas = ', npas
+        write(*,*)' nexca = ', nexca
+      endif        
+c
+c
+c Gestion calendrier
+
+         CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ini
+
 c
       IF (ok_journe) THEN
 c
-C         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
-         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
-         zjulian = zjulian + dayref
-c
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ini
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
          DO i = 1, iim
             zx_lon(i,1) = rlon(i+1)
-            zx_lon(i,jjm+1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
          ENDDO
          DO ll=1,klev
             znivsig(ll)=float(ll)
          ENDDO
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
-         CALL histbeg("histday", iim,zx_lon, jjm+1,zx_lat,
-     .                 1,iim,1,jjm+1, 0, zjulian, dtime, 
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         CALL histbeg("histday", iim,zx_lon, jjmp1,zx_lat,
+     .                 1,iim,1,jjmp1, 0, zjulian, dtime, 
      .                 nhori, nid_day)
-c         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
-c     .                 klev, presnivs, nvert)
-         call histvert(nid_day, 'sig_s', 'Niveaux sigma','-',
-     .              klev, znivsig, nvert)
+         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+c        call histvert(nid_day, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
 c
          zsto = dtime
          zout = dtime * FLOAT(ecrit_day)
+C Essai writephys
+c        nom_fichier = 'histday1'
+c        call writephy_ini(fid_day,nom_fichier,klon,iim,jjmp1,klev,
+c    .                     rlon,rlat, presnivs,
+c    .                     zjulian, dtime)
+c        call writephy_def(prof2d_on, fid_day, "once", zsto, zout, 0)
+c        call writephy_def(prof3d_on, fid_day, "once", zsto, zout,
+c    .                                                         klev)
+c        call writephy_def(prof2d_av, fid_day, "ave(X)", zsto, zout, 0) 
+c        call writephy_def(prof3d_av, fid_day, "ave(X)", zsto, zout, 
+c    .                                                         klev)
+ 
 c
          CALL histdef(nid_day, "phis", "Surface geop. height", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "once", zsto,zout)
 c
          CALL histdef(nid_day, "aire", "Grid area", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "once", zsto,zout)
 c
@@ -694,85 +812,152 @@
 c
          CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "tter", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "tlic", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "toce", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "tsic", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "rain", "Precipitation", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "snow", "Snow fall", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "snow_cov", "Snow cover", "mm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "evap", "Evaporation", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "sols", "Solar rad. at surf.", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "soll", "IR rad. at surface", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "frtu", "Zonal wind stress", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "frtv", "Meridional wind stress", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_day, "ruis", "Runoff", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
-c
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+C §§§ PB flux pour chauqe sous surface
+C
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_day, "pourc_"//clnsurf(nsrf), 
+     $         "Fraction"//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_day, "tsol_"//clnsurf(nsrf), 
+     $         "Fraction"//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_day, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+c
+           call histdef(nid_day, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_day, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf),"Pa",
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+
+           call histdef(nid_day, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_day, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_day, "rugs_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+
+C§§§
+         END DO 
+           
          CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "cldq", "Cloud liquid water path", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
@@ -780,42 +965,35 @@
 c
          CALL histdef(nid_day, "temp", "Air temperature", "K",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "ovap", "Specific humidity", "Kg/Kg",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "geop", "Geopotential height", "m",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "vitw", "Vertical wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_day, "pres", "Air pressure", "Pa",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histend(nid_day)
 c
-         ndex(1) = 0
-c
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
-         CALL histwrite(nid_day,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
-         CALL histwrite(nid_day,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+         ndex2d = 0
+         ndex3d = 0
 c
       ENDIF ! fin de test sur ok_journe
@@ -823,24 +1001,23 @@
       IF (ok_mensuel) THEN
 c
-c         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
-         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
-         zjulian = zjulian + dayref
-c
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ini
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
          DO i = 1, iim
             zx_lon(i,1) = rlon(i+1)
-            zx_lon(i,jjm+1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
          ENDDO
          DO ll=1,klev
             znivsig(ll)=float(ll)
          ENDDO
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
-         CALL histbeg("histmth", iim,zx_lon, jjm+1,zx_lat,
-     .                 1,iim,1,jjm+1, 0, zjulian, dtime, 
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         CALL histbeg("histmth", iim,zx_lon, jjmp1,zx_lat,
+     .                 1,iim,1,jjmp1, 0, zjulian, dtime, 
      .                 nhori, nid_mth)
-c         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
-c     .                 klev, presnivs, nvert)
-         call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-',
-     .              klev, znivsig, nvert)
+         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+c        call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
 c
          zsto = dtime
@@ -848,9 +1025,9 @@
 c
          CALL histdef(nid_mth, "phis", "Surface geop. height", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "once",  zsto,zout)
 c
          CALL histdef(nid_mth, "aire", "Grid area", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "once",  zsto,zout)
 c
@@ -858,268 +1035,351 @@
 c
          CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "qsol", "Surface humidity", "mm",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "rain", "Precipitation", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "plul", "Large-scale Precip.", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "pluc", "Convective Precip.", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "snow", "Snow fall", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "ages", "Snow age", "day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "snow_cov", "Snow cover", "mm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "evap", "Evaporation", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "tops0", "Solar rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "ruis", "Runoff", "mm/day",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
-c
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_mth, "pourc_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_mth, "tsol_"//clnsurf(nsrf), 
+     $         "Fraction "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_mth, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+c
+           call histdef(nid_mth, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+C
+           call histdef(nid_mth, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf), "Pa",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+
+           call histdef(nid_mth, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+c
+           call histdef(nid_mth, "albe_"//clnsurf(nsrf), 
+     $         "Albedo surf. "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+c
+           call histdef(nid_mth, "rugs_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ages_"//clnsurf(nsrf), "Snow age","day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+
+         END DO
+C
          CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "albs", "Surface albedo", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_mth, "albslw", "Surface albedo LW", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "cldq", "Cloud liquid water path", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
-     .                "ave(X)", zsto,zout)
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+cKE43
+      IF (iflag_con .EQ. 4) THEN ! sb
+c
+         CALL histdef(nid_mth, "cape", "Conv avlbl pot ener", "J/Kg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "pbase", "Cld base pressure", "hPa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ptop", "Cld top pressure", "hPa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "fbase", "Cld base mass flux", "Kg/m2/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+c
+      ENDIF
+c34EK
 c
 c Champs 3D:
 c
          CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "Kg/Kg",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "oliq", "Liquid water content", "kg/kg",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqcon", "Convection dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+         CALL histdef(nid_mth, "ptconv", "POINTS CONVECTIFS"," ",
      .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "ovap", "Specific humidity", "Kg/Kg",
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
      .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "geop", "Geopotential height", "m",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "oliq", "Liquid water content", "kg/kg",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "Kg/Kg/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dqcon", "Convection dQ", "Kg/Kg/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "Kg/Kg/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-         CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "Kg/Kg/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-     .                "ave(X)", zsto,zout)
-c
-c         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
-c     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-c     .                "ave(X)", zsto,zout)
-c
-c         CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "Kg/Kg/s",
-c     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
-c     .                "ave(X)", zsto,zout)
+
+c
+         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+         CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dtsw0", "SW radiation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dtlw0", "LW radiation dT", "K/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          IF (ok_orodr) THEN
          CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
@@ -1128,14 +1388,14 @@
          IF (ok_orolf) THEN
          CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
          CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
          ENDIF
 C
          CALL histdef(nid_mth, "ozone", "Ozone concentration", "-",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
 c
@@ -1145,5 +1405,5 @@
          WRITE(str2,'(i2.2)') iq
          CALL histdef(nid_mth, "trac"//str2, "Tracer No."//str2, "-",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "ave(X)", zsto,zout)
          ELSE
@@ -1154,15 +1414,30 @@
          ENDIF
 c
+cKE43
+      IF (iflag_con.EQ.4) THEN ! (sb)
+c
+         CALL histdef(nid_mth, "upwd", "saturated updraft", "Kg/m2/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dnwd", "saturated downdraft","Kg/m2/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dnwd0", "unsat. downdraft", "Kg/m2/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth,"Ma","undilute adiab updraft","Kg/m2/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+c
+      ENDIF
+c34EK
          CALL histend(nid_mth)
 c
-         ndex(1) = 0
-c
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
-         CALL histwrite(nid_mth,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
-C
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
-         CALL histwrite(nid_mth,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+         ndex2d = 0
+         ndex3d = 0
 c
       ENDIF ! fin de test sur ok_mensuel
@@ -1171,24 +1446,24 @@
       IF (ok_instan) THEN
 c
-c         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
-         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
-         zjulian = zjulian + dayref
-c
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ini
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
          DO i = 1, iim
             zx_lon(i,1) = rlon(i+1)
-            zx_lon(i,jjm+1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
          ENDDO
          DO ll=1,klev
             znivsig(ll)=float(ll)
          ENDDO
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
-         CALL histbeg("histins", iim,zx_lon, jjm+1,zx_lat,
-     .                 1,iim,1,jjm+1, 0, zjulian, dtime,
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         CALL histbeg("histins", iim,zx_lon, jjmp1,zx_lat,
+     .                 1,iim,1,jjmp1, 0, zjulian, dtime,
      .                 nhori, nid_ins)
-c         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
-c     .                 klev, presnivs, nvert)
-         call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
-     .              klev, znivsig, nvert)
+         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+c        call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
+c    .              klev, znivsig, nvert)
+c
 c
          zsto = dtime * ecrit_ins
@@ -1196,56 +1471,191 @@
 C
          CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "once", zsto,zout)
 c
          CALL histdef(nid_ins, "aire", "Grid area", "-",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "once", zsto,zout)
 c
 c Champs 2D:
 c
-         CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+        CALL histdef(nid_ins, "tsol", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
      .                "inst(X)", zsto,zout)
 c
+        CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "plul", "Large-scale Precip.", "mm/day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pluc", "Convective Precip.", "mm/day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+
+        CALL histdef(nid_ins, "qsol", "Surface humidity", "mm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "rain", "Precipitation", "mm/day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow", "Snow fall", "mm/day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow_cov", "Snow cover", "mm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
          CALL histdef(nid_ins, "topl", "OLR", "W/m2",
-     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
      .                "inst(X)", zsto,zout)
 c
+         CALL histdef(nid_ins, "evap", "Evaporation", "mm/day",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "solldown", "Down. IR rad. at surface", 
+     .                "W/m2", iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfo", "Boundary-layer dTs(o)", "K/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdft", "Boundary-layer dTs(t)", "K/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfg", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+      CALL histdef(nid_ins, "dtsvdfi", "Boundary-layer dTs(g)", "K/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         DO nsrf = 1, nbsrf
+C
+           call histdef(nid_ins, "pourc_"//clnsurf(nsrf), 
+     $         "Fraction"//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "sens_"//clnsurf(nsrf), 
+     $         "Sensible heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "tsol_"//clnsurf(nsrf), 
+     $         "Surface Temperature"//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "lat_"//clnsurf(nsrf), 
+     $         "Latent heat flux "//clnsurf(nsrf), "W/m2",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+C
+           call histdef(nid_ins, "taux_"//clnsurf(nsrf), 
+     $         "Zonal wind stress"//clnsurf(nsrf),"Pa",
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+
+           call histdef(nid_ins, "tauy_"//clnsurf(nsrf), 
+     $         "Meridional xind stress "//clnsurf(nsrf), "Pa",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "albe_"//clnsurf(nsrf), 
+     $         "Albedo "//clnsurf(nsrf), "-",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+c
+           call histdef(nid_ins, "rugs_"//clnsurf(nsrf), 
+     $         "rugosite "//clnsurf(nsrf), "-",  
+     $         iim,jjmp1,nhori, 1,1,1, -99, 32,
+     $         "inst(X)", zsto,zout)
+C§§§
+         END DO 
+         CALL histdef(nid_ins, "rugs", "rugosity", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+c
+         CALL histdef(nid_ins, "albs", "Surface albedo", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_ins, "albslw", "Surface albedo LW", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+c
 c Champs 3D:
 c
          CALL histdef(nid_ins, "temp", "Temperature", "K",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "inst(X)", zsto,zout)
 c
          CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "inst(X)", zsto,zout)
 c
          CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "inst(X)", zsto,zout)
 c
          CALL histdef(nid_ins, "geop", "Geopotential height", "m",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "inst(X)", zsto,zout)
 c
          CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
-     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
      .                "inst(X)", zsto,zout)
 c
+         CALL histdef(nid_ins, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+
          CALL histend(nid_ins)
 c
-         ndex(1) = 0
-c
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
-         CALL histwrite(nid_ins,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-         i = NINT(zout/zsto)
-         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
-         CALL histwrite(nid_ins,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+         ndex2d = 0
+         ndex3d = 0
 c
       ENDIF
+
+c$$$PB Positionner date0 pour initialisation de ORCHIDEE
+c$$$      date0 = zjulian
+      date0 = day_ini
+      WRITE(*,*) 'physiq date0 : ',date0
 c
 c
@@ -1260,19 +1670,4 @@
 cc         ENDDO
 c
-         IF (ok_oasis) THEN
-         DO i = 1, klon
-           oas_sols(i) = 0.0
-           oas_nsol(i) = 0.0
-           oas_rain(i) = 0.0
-           oas_snow(i) = 0.0
-           oas_evap(i) = 0.0
-           oas_ruis(i) = 0.0
-           oas_tsol(i) = 0.0
-           oas_fder(i) = 0.0
-           oas_albe(i) = 0.0
-           oas_taux(i) = 0.0
-           oas_tauy(i) = 0.0
-         ENDDO
-         ENDIF
 c
       ENDIF
@@ -1328,4 +1723,23 @@
       ENDIF
 c
+c Diagnostiquer la tendance dynamique
+c
+      IF (ancien_ok) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
+            d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
+         ENDDO
+         ENDDO
+      ELSE
+         DO k = 1, klev
+         DO i = 1, klon
+            d_t_dyn(i,k) = 0.0
+            d_q_dyn(i,k) = 0.0
+         ENDDO
+         ENDDO
+         ancien_ok = .TRUE.
+      ENDIF
+c
 c Ajouter le geopotentiel du sol:
 c
@@ -1338,5 +1752,4 @@
 c Verifier les temperatures
 c
-
       CALL hgardfou(t_seri,ftsol,'debutphy')
 c
@@ -1352,20 +1765,5 @@
          idayvrai = NINT(xjour)
          PRINT *,' PHYS cond  julien ',julien,idayvrai
-         CALL condsurf(julien,idayvrai, pctsrf ,
-     .                  lmt_sst,lmt_alb,lmt_rug,lmt_bils  )
          CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
-      ENDIF
-c
- 
-      IF (ok_ocean) THEN
-         DO i = 1, klon
-            ftsol(i,is_oce) = lmt_sst(i) + deltat(i)
-         ENDDO
-
-      ELSE
-         DO i = 1, klon
-            ftsol(i,is_oce) = lmt_sst(i)
-         ENDDO
-
       ENDIF
 c
@@ -1391,8 +1789,10 @@
 c
       DO i = 1, klon
-         frugs(i,is_ter) = SQRT(lmt_rug(i)**2+rugoro(i)**2)
-         frugs(i,is_lic) = rugoro(i)
-         frugs(i,is_oce) = rugmer(i)
-         frugs(i,is_sic) = 0.001
+c       if (.not. ok_veget) then
+c          frugs(i,is_ter) = SQRT(frugs(i,is_ter)**2+rugoro(i)**2)
+c       endif 
+c         frugs(i,is_lic) = rugoro(i)
+c         frugs(i,is_oce) = rugmer(i)
+c         frugs(i,is_sic) = 0.001
          zxrugs(i) = 0.0
       ENDDO
@@ -1404,23 +1804,65 @@
       DO nsrf = 1, nbsrf
       DO i = 1, klon
-         zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf)
-      ENDDO
-      ENDDO
-c
-      CALL clmain(dtime,pctsrf,
-     e            t_seri,q_seri,u_seri,v_seri,soil_model,
-     e            ftsol,soilcap,soilflux,paprs,pplay,radsol,
-     e            fsnow,fqsol,
-     e            rlat, frugs,
+            zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf)
+      ENDDO
+      ENDDO
+c
+C calculs necessaires au calcul de l'albedo dans l'interface
+c
+      CALL orbite(FLOAT(julien),zlongi,dist)
+      IF (cycle_diurne) THEN
+        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
+        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
+      ELSE
+        rmu0 = -999.999
+      ENDIF
+
+      fder = dlw
+
+      CALL clmain(dtime,itap,zjulian,pctsrf,
+     e            t_seri,q_seri,u_seri,v_seri,
+     e            julien, rmu0, 
+     e            ok_veget, ocean, npas, nexca, ftsol,
+     $            soil_model,ftsoil,
+     $            paprs,pplay,radsol, fsnow,fqsol,fevap,falbe,falblw,
+     $            fluxlat,
+     e            rain_fall, snow_fall, solsw, sollw, sollwdown, fder,
+     e            rlon, rlat, cufi, cvfi, frugs,
+     e            debut, lafin, agesno,rugoro ,
      s            d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts,
-     s            fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,rugmer,
+     s            fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,
      s            dsens, devap,
      s            ycoefh,yu1,yv1) 
-c
-      DO i = 1, klon
-         sens(i) = - fluxt(i,1) ! flux de chaleur sensible au sol
-         evap(i) = - fluxq(i,1) ! flux d'evaporation au sol
-         fder(i) = dsens(i) + devap(i)
-      ENDDO
+
+c
+C§§§ PB
+C§§§ Incrementation des flux
+C§§
+      zxfluxt=0.
+      zxfluxq=0.
+      zxfluxu=0.
+      zxfluxv=0.
+      DO nsrf = 1, nbsrf
+        DO k = 1, klev
+          DO i = 1, klon
+            zxfluxt(i,k) = zxfluxt(i,k) + 
+     $          fluxt(i,k,nsrf) * pctsrf( i, nsrf)
+            zxfluxq(i,k) = zxfluxq(i,k) + 
+     $          fluxq(i,k,nsrf) * pctsrf( i, nsrf)
+            zxfluxu(i,k) = zxfluxu(i,k) + 
+     $          fluxu(i,k,nsrf) * pctsrf( i, nsrf)
+            zxfluxv(i,k) = zxfluxv(i,k) + 
+     $          fluxv(i,k,nsrf) * pctsrf( i, nsrf)
+          END DO 
+        END DO 
+      END DO 
+      DO i = 1, klon
+         sens(i) = - zxfluxt(i,1) ! flux de chaleur sensible au sol
+c         evap(i) = - fluxq(i,1) ! flux d'evaporation au sol
+         evap(i) = - zxfluxq(i,1) ! flux d'evaporation au sol
+         fder(i) = dlw(i) + dsens(i) + devap(i)
+      ENDDO
+
+
       DO k = 1, klev
       DO i = 1, klon
@@ -1436,9 +1878,17 @@
       DO i = 1, klon
          zxtsol(i) = 0.0
+         IF ( abs( pctsrf(i, is_ter) + pctsrf(i, is_lic) + 
+     $       pctsrf(i, is_oce) + pctsrf(i, is_sic)  - 1.) .GT. EPSFRA) 
+     $       THEN 
+             WRITE(*,*) 'physiq : pb sous surface au point ', i, 
+     $           pctsrf(i, 1 : nbsrf)
+         ENDIF 
       ENDDO
       DO nsrf = 1, nbsrf
       DO i = 1, klon
-         ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf)
-         zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+c$$$        IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN 
+            ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf)
+            zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+c$$$        ENDIF 
       ENDDO
       ENDDO
@@ -1448,28 +1898,20 @@
 c
       DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         IF (pctsrf(i,nsrf).LT.epsfra) ftsol(i,nsrf) = zxtsol(i)
-      ENDDO
-      ENDDO
-
-c
-c Appeler le modele du sol
-c
-      IF (soil_model) THEN
-         DO nsrf = 1, nbsrf
-         CALL soil(dtime, nsrf, fsnow(1,nsrf),
-     .             ftsol(1,nsrf), ftsoil(1,1,nsrf),
-     .             soilcap(1,nsrf), soilflux(1,nsrf))
-         ENDDO
-      ENDIF
+        DO i = 1, klon
+          IF (pctsrf(i,nsrf) .LT. epsfra) ftsol(i,nsrf) = zxtsol(i)
+        ENDDO
+      ENDDO
+
 c
 c Calculer la derive du flux infrarouge
 c
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         fder(i) = fder(i) - 4.0*RSIGMA*zxtsol(i)**3 *
-     .                       (ftsol(i,nsrf)-zxtsol(i))
-     .                      *pctsrf(i,nsrf)
-      ENDDO
+c$$$      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+c$$$        IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN 
+            dlw(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+c$$$     .          *(ftsol(i,nsrf)-zxtsol(i))
+c$$$     .          *pctsrf(i,nsrf)
+c$$$        ENDIF 
+c$$$      ENDDO
       ENDDO
 c
@@ -1478,5 +1920,5 @@
       DO k = 1, klev
       DO i = 1, klon
-         conv_q(i,k) = d_qx_dyn(i,k,ivap) 
+         conv_q(i,k) = d_q_dyn(i,k) 
      .               + d_q_vdf(i,k)/dtime
          conv_t(i,k) = d_t_dyn(i,k) 
@@ -1485,5 +1927,19 @@
       ENDDO
       IF (check) THEN
-         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"avantcon=")
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
+         PRINT*, "avantcon=", za
+      ENDIF
+      zx_ajustq = .FALSE.
+      IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
+      IF (zx_ajustq) THEN
+         DO i = 1, klon
+            z_avant(i) = 0.0
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+            z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))
+     .                        *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDDO
+         ENDDO
       ENDIF
       IF (iflag_con.EQ.1) THEN
@@ -1494,8 +1950,10 @@
       ELSE IF (iflag_con.EQ.2) THEN
       CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
-     e            conv_t, conv_q, fluxq(1,1), omega,
+     e            conv_t, conv_q, zxfluxq(1,1), omega,
      s            d_t_con, d_q_con, rain_con, snow_con,
      s            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
      s            kcbot, kctop, kdtop, pmflxr, pmflxs)
+      WHERE (rain_con < 0.) rain_con = 0.
+      WHERE (snow_con < 0.) snow_con = 0.
       DO i = 1, klon
          ibas_con(i) = klev+1 - kcbot(i)
@@ -1507,35 +1965,118 @@
 c    s             d_t_con, d_q_con, 
 c    s             rain_con, snow_con, ibas_con, itop_con)
+cKE43
+      ELSE IF (iflag_con.EQ.4) THEN
+c nb of tracers for the KE convection:
+          if (nqmax .GE. 4) then
+              ntra = nbtr
+          else
+              ntra = 1 
+          endif
+cke43 (arguments inutiles enleves => des SAVE dans conema43?)
+c$$$          CALL conema43(dtime,paprs,pplay,t_seri,q_seri,
+c$$$     $        u_seri,v_seri,tr_seri,nbtr,
+c$$$     .        ema_workcbmf,
+c$$$     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+c$$$     .        wdn, tdn, qdn,
+c$$$     .        rain_con, snow_con, ibas_con, itop_con,
+c$$$     .        upwd,dnwd,dnwd0,bas,top,Ma,cape,tvp,rflag,
+c$$$     .        pbase
+c$$$     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+c$$$     .        pori_con,plcl_con,dtma_con,dtlcl_con)
+          if (0.eq.1) then ! vectorise
+          CALL conemav (dtime,paprs,pplay,t_seri,q_seri,
+     .        u_seri,v_seri,tr_seri,nbtr,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,
+c    .        Ma,cape,tvp,(/(nint(rflag(i)),i=1,size(rflag))/),
+     .        Ma,cape,tvp,iflagctrl,
+     .       pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+
+          else
+
+          CALL conema (dtime,paprs,pplay,t_seri,q_seri,
+     $        u_seri,v_seri,tr_seri,nbtr,
+     .        ema_work1,ema_work2,
+     .        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,
+c$$$     .        wdn, tdn, qdn,
+     .        rain_con, snow_con, ibas_con, itop_con,
+     .        upwd,dnwd,dnwd0,bas,top,Ma,cape,tvp,rflag,
+     .        pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr)
+c$$$     .        pori_con,plcl_con,dtma_con,dtlcl_con)
+          endif
+          DO i = 1, klon
+            ema_pcb(i)  = pbase(i)
+          ENDDO
+          DO i = 1, klon
+            ema_pct(i)  = paprs(i,itop_con(i))
+          ENDDO
+          DO i = 1, klon
+            ema_cbmf(i) = ema_workcbmf(i)
+          ENDDO      
       ELSE
-      PRINT*, "iflag_con non-prevu", iflag_con
-      CALL abort
+          PRINT*, "iflag_con non-prevu", iflag_con
+          CALL abort
       ENDIF
+
       CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
      .              d_u_con, d_v_con)
       DO k = 1, klev
-      DO i = 1, klon
+        DO i = 1, klon
          t_seri(i,k) = t_seri(i,k) + d_t_con(i,k)
          q_seri(i,k) = q_seri(i,k) + d_q_con(i,k)
          u_seri(i,k) = u_seri(i,k) + d_u_con(i,k)
          v_seri(i,k) = v_seri(i,k) + d_v_con(i,k)
-      ENDDO
+        ENDDO
       ENDDO
       IF (check) THEN
-         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"aprescon=")
-         zx_t = 0.0
-         DO i = 1, klon
-            zx_t = zx_t + rain_con(i)+snow_con(i)
-         ENDDO
-         zx_t = zx_t/FLOAT(klon)*dtime
-         PRINT*, "Precip=", zx_t
+          za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
+          PRINT*, "aprescon=", za
+          zx_t = 0.0
+          za = 0.0
+          DO i = 1, klon
+            za = za + paire(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_con(i)+snow_con(i))*paire(i)/FLOAT(klon)
+          ENDDO
+          zx_t = zx_t/za*dtime
+          PRINT*, "Precip=", zx_t
       ENDIF
+      IF (zx_ajustq) THEN
+          DO i = 1, klon
+            z_apres(i) = 0.0
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))
+     .            *(paprs(i,k)-paprs(i,k+1))/RG
+            ENDDO
+          ENDDO
+          DO i = 1, klon
+            z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)
+     .          /z_apres(i)
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              IF (z_factor(i).GT.(1.0+1.0E-08) .OR.
+     .            z_factor(i).LT.(1.0-1.0E-08)) THEN
+                  q_seri(i,k) = q_seri(i,k) * z_factor(i)
+              ENDIF
+            ENDDO
+          ENDDO
+      ENDIF
+      zx_ajustq=.FALSE.
 c
       IF (nqmax.GT.2) THEN !--melange convectif de traceurs
 c
-      IF (iflag_con.NE.2) THEN
-         PRINT*, "Pour l instant, seul conflx fonctionne avec traceurs"
-         PRINT*,' Mettre iflag_con = 2  dans  run.def et repasser  !'
-         CALL abort
-      ENDIF
+          IF (iflag_con .NE. 2 .AND.  iflag_con .NE. 4 ) THEN 
+              PRINT*, 'Pour l instant, seul conflx fonctionne ',
+     $            'avec traceurs', iflag_con
+              PRINT*,' Mettre iflag_con', 
+     $            ' = 2  ou 4 dans run.def et repasser'
+              CALL abort
+              ENDIF 
 c
       ENDIF !--nqmax.GT.2
@@ -1543,5 +2084,16 @@
 c Appeler l'ajustement sec
 c
-C appel supprime pour le moment
+      CALL ajsec(paprs, pplay, t_seri, q_seri, d_t_ajs, d_q_ajs)
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_ajs(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_ajs(i,k)
+      ENDDO
+      ENDDO
+
+c   RATQS
+      call calcratqs (
+     I            paprs,pplay,q_seri,d_t_con,d_t_ajs
+     O           ,ratqs,zpt_conv)
 c
 c Appeler le processus de condensation a grande echelle
@@ -1549,9 +2101,12 @@
 c
       CALL fisrtilp_tr(dtime,paprs,pplay,
-     .           t_seri, q_seri,
+     .           t_seri, q_seri,ratqs,
      .           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,
      .           rain_lsc, snow_lsc,
      .           pfrac_impa, pfrac_nucl, pfrac_1nucl,
-     .           frac_impa, frac_nucl )
+     .           frac_impa, frac_nucl,
+     .           prfl, psfl)
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
       DO k = 1, klev
       DO i = 1, klon
@@ -1564,10 +2119,13 @@
       ENDDO
       IF (check) THEN
-         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"apresilp=")
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
+         PRINT*, "apresilp=", za
          zx_t = 0.0
+         za = 0.0
          DO i = 1, klon
-            zx_t = zx_t + rain_lsc(i)+snow_lsc(i)
-         ENDDO
-         zx_t = zx_t/FLOAT(klon)*dtime
+            za = za + paire(i)/FLOAT(klon)
+            zx_t = zx_t + (rain_lsc(i)+snow_lsc(i))*paire(i)/FLOAT(klon)
+        ENDDO
+         zx_t = zx_t/za*dtime
          PRINT*, "Precip=", zx_t
       ENDIF
@@ -1576,7 +2134,21 @@
 c
       IF (iflag_con.EQ.2) THEN ! seulement pour Tiedtke
-      CALL diagcld(paprs,pplay,t_seri,q_seri,
+      CALL diagcld1(paprs,pplay,
      .             rain_con,snow_con,ibas_con,itop_con,
      .             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Nuages stratus artificiels:
+c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
       DO k = 1, klev
       DO i = 1, klon
@@ -1628,36 +2200,28 @@
 c
       IF (MOD(itaprad,radpas).EQ.0) THEN
-      CALL orbite(FLOAT(julien),zlongi,dist)
-      IF (cycle_diurne) THEN
-        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
-        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
-c        CALL zenith(zlongi,gmtime,rlat,rlon,rmu0,fract) !va disparaitre
-        CALL alboc_cd(rmu0,alb_eau)
-      ELSE
-        CALL angle(zlongi,rlat,fract,rmu0)
-        CALL alboc(FLOAT(julien),rlat,alb_eau)
-      ENDIF
-      CALL albsno(veget,agesno,alb_neig)
-      DO i = 1, klon
-         zx_alb_oce = alb_eau(i)
-         IF (pctsrf(i,is_oce).GT.epsfra .AND. ftsol(i,is_oce).LT.271.35)
-     .   zx_alb_oce = 0.6 ! pour slab_ocean
-         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_lic)/(fsnow(i,is_lic)+10.0)))
-         zx_alb_lic = alb_neig(i)*zfra + 0.6*(1.0-zfra)
-         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_ter)/(fsnow(i,is_ter)+10.0)))
-         zx_alb_ter = alb_neig(i)*zfra + lmt_alb(i)*(1.0-zfra)
-         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_sic)/(fsnow(i,is_sic)+10.0)))
-         zx_alb_sic = alb_neig(i)*zfra + 0.6*(1.0-zfra)
-         albsol(i) = zx_alb_oce * pctsrf(i,is_oce)
-     .             + zx_alb_lic * pctsrf(i,is_lic)
-     .             + zx_alb_ter * pctsrf(i,is_ter)
-     .             + zx_alb_sic * pctsrf(i,is_sic)
-      ENDDO
+      DO i = 1, klon
+         albsol(i) = falbe(i,is_oce) * pctsrf(i,is_oce)
+     .             + falbe(i,is_lic) * pctsrf(i,is_lic)
+     .             + falbe(i,is_ter) * pctsrf(i,is_ter)
+     .             + falbe(i,is_sic) * pctsrf(i,is_sic)
+         albsollw(i) = falblw(i,is_oce) * pctsrf(i,is_oce)
+     .               + falblw(i,is_lic) * pctsrf(i,is_lic)
+     .               + falblw(i,is_ter) * pctsrf(i,is_ter)
+     .               + falblw(i,is_sic) * pctsrf(i,is_sic)
+      ENDDO
+!      if (debut) then
+!        albsol1 = albsol
+!        albsollw1 = albsollw
+!      endif
+!      albsol = albsol1
+!      albsollw = albsollw1
       CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
      e            (dist, rmu0, fract, co2_ppm, solaire,
-     e             paprs, pplay,zxtsol,albsol, t_seri,q_seri,wo,
+     e             paprs, pplay,zxtsol,albsol, albsollw, t_seri,q_seri,
+     e             wo,
      e             cldfra, cldemi, cldtau,
      s             heat,heat0,cool,cool0,radsol,albpla,
      s             topsw,toplw,solsw,sollw,
+     s             sollwdown,
      s             topsw0,toplw0,solsw0,sollw0)
       itaprad = 0
@@ -1676,6 +2240,6 @@
 c Calculer l'hydrologie de la surface
 c
-      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, evap,
-     .            agesno, ftsol,fqsol,fsnow, ruis)
+c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+c     .            agesno, ftsol,fqsol,fsnow, ruis)
 c
       DO i = 1, klon
@@ -1692,12 +2256,12 @@
 c Si une sous-fraction n'existe pas, elle prend la valeur moyenne
 c
-      DO nsrf = 1, nbsrf
-      DO i = 1, klon
-         IF (pctsrf(i,nsrf).LT.epsfra) THEN
-            fqsol(i,nsrf) = zxqsol(i)
-            fsnow(i,nsrf) = zxsnow(i)
-         ENDIF
-      ENDDO
-      ENDDO
+c$$$      DO nsrf = 1, nbsrf
+c$$$      DO i = 1, klon
+c$$$         IF (pctsrf(i,nsrf).LT.epsfra) THEN
+c$$$            fqsol(i,nsrf) = zxqsol(i)
+c$$$            fsnow(i,nsrf) = zxsnow(i)
+c$$$         ENDIF
+c$$$      ENDDO
+c$$$      ENDDO
 c
 c Calculer le bilan du sol et la derive de temperature (couplage)
@@ -1706,14 +2270,4 @@
          bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
       ENDDO
-      IF (ok_ocean) THEN
-         DO i = 1, klon
-            cthermiq = cyang
-            IF (ftsol(i,is_oce).LT. 271.35) cthermiq = cbing
-            IF (pctsrf(i,is_oce).GT.epsfra) deltat(i) = deltat(i) +
-     .                          (bils(i)-lmt_bils(i))/cthermiq * dtime
-            IF (deltat(i).GT.15.0 ) deltat(i) = 15.0
-            IF (deltat(i).LT.-15.0) deltat(i) = -15.0
-         ENDDO
-      ENDIF
 c
 cmoddeblott(jan95)
@@ -1734,9 +2288,9 @@
         ENDIF
         ENDDO
-        igwdim=MAX(1,igwd)
+c        igwdim=MAX(1,igwd)
 c
         CALL drag_noro(klon,klev,dtime,paprs,pplay,
      e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
-     e                   igwd,igwdim,idx,itest,
+     e                   igwd,idx,itest,
      e                   t_seri, u_seri, v_seri,
      s                   zulow, zvlow, zustr, zvstr,
@@ -1766,9 +2320,9 @@
         ENDIF
         ENDDO
-        igwdim=MAX(1,igwd)
+c        igwdim=MAX(1,igwd)
 c
         CALL lift_noro(klon,klev,dtime,paprs,pplay,
-     e                   rlat,zmea,zstd, zsig, zgam, zthe,zpic,zval,
-     e                   igwd,igwdim,idx,itest,
+     e                   rlat,zmea,zstd,zpic,
+     e                   itest,
      e                   t_seri, u_seri, v_seri,
      s                   zulow, zvlow, zustr, zvstr,
@@ -1792,9 +2346,27 @@
 c   Calcul  des tendances traceurs
 c====================================================================
+C Pascale : il faut quand meme apeller phytrac car il gere les sorties
+cKE43       des traceurs => il faut donc mettre des flags a .false.
+      IF (iflag_con.EQ.4) THEN
+c           on ajoute les tendances calculees par KE43
+c$$$ OM on onhibe la convection sur les traceurs
+        DO iq=1, nqmax-2 ! Sandrine a -3 ???
+c$$$ OM on inhibe la convection sur les traceur
+c$$$        DO k = 1, nlev
+c$$$        DO i = 1, klon
+c$$$          tr_seri(i,k,iq) = tr_seri(i,k,iq) + d_tr(i,k,iq)
+c$$$        ENDDO
+c$$$        ENDDO
+        WRITE(iqn,'(i2.2)') iq
+        CALL minmaxqfi(tr_seri(1,1,iq),0.,1.e33,'couche lim iq='//iqn)
+        ENDDO
 CMAF modif pour garder info du nombre de traceurs auxquels
 C la physique s'applique
+      ELSE
+CMAF modif pour garder info du nombre de traceurs auxquels
+C la physique s'applique
 C
       call phytrac (rnpb,
-     I                   debut,
+     I                   debut,lafin,
      I                   nqmax-2,
      I                   nlon,nlev,dtime,
@@ -1805,11 +2377,15 @@
      I                   rlon,presnivs,paire,pphis,
      O                   tr_seri)
+      ENDIF 
 
       IF (offline) THEN
-      call phystoke (
-     I                   nlon,nlev,pdtphys,
-     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+
+	 call phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
      I                   ycoefh,yu1,yv1,ftsol,pctsrf,
-     I                   frac_impa, frac_nucl)
+     I                   frac_impa, frac_nucl,
+     I                   pphis,paire,dtime,itap)
+
 
       ENDIF
@@ -1824,420 +2400,669 @@
 c Accumuler les variables a stocker dans les fichiers histoire:
 c
-      IF (ok_oasis) THEN ! couplage oasis
-      DO i = 1, klon
-        oas_sols(i) = oas_sols(i) + solsw(i)          / FLOAT(nexca)
-        oas_nsol(i) = oas_nsol(i) + (bils(i)-solsw(i))/ FLOAT(nexca)
-        oas_rain(i) = oas_rain(i) + rain_fall(i)      / FLOAT(nexca)
-        oas_snow(i) = oas_snow(i) + snow_fall(i)      / FLOAT(nexca)
-        oas_evap(i) = oas_evap(i) + evap(i)           / FLOAT(nexca)
-        oas_tsol(i) = oas_tsol(i) + zxtsol(i)         / FLOAT(nexca)
-        oas_fder(i) = oas_fder(i) + fder(i)           / FLOAT(nexca)
-        oas_albe(i) = oas_albe(i) + albsol(i)         / FLOAT(nexca)
-        oas_taux(i) = oas_taux(i) + fluxu(i,1)        / FLOAT(nexca)
-        oas_tauy(i) = oas_tauy(i) + fluxv(i,1)        / FLOAT(nexca)
-        oas_ruis(i) = oas_ruis(i) + ruis(i)       /FLOAT(nexca)/dtime
-      ENDDO
+c
+c
+
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         zsto = dtime
+         zout = dtime * FLOAT(ecrit_day)
+
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_day,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+         varname = 'phis'
+         vartitle= 'Surface geop. height'
+         varunits= '-'
+c        call writephy(fid_day,prof2d_on,varname,pphis,vartitle,
+c    .                                                    varunits)
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+         CALL histwrite(nid_day,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+         varname = 'aire'
+         vartitle= 'Grid area'
+         varunits= '-'
+c        call writephy(fid_day,prof2d_on,varname,paire,vartitle,
+c    .                                                    varunits)
+C
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_day,"tsol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tsol',zxtsol,
+c    .              'Surface Temperature','K')
+c
+C
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d ,zx_tmp_2d)
+      CALL histwrite(nid_day,"tter",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tter',ftsol(1 : klon, is_ter),
+c    .              'Surface Temperature','K')
+C
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_lic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_day,"tlic",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tlic',ftsol(1 : klon, is_lic),
+c    .              'Surface Temperature','K')
+C
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_oce)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_day,"toce",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'toce',ftsol(1 : klon, is_oce),
+c    .              'Surface Temperature','K')
+C
+      zx_tmp_fi2d(1 : klon) = ftsol(1 : klon, is_sic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_day,"tsic",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tsic',ftsol(1 : klon, is_sic),
+c    .              'Surface Temperature','K')
+C
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"psol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c Essai writephys
+      varname = 'psol'
+      vartitle= 'pression au sol'
+      varunits= 'hPa'
+c     call writephy(fid_day,prof2d_av,varname,zx_tmp_fi2d,vartitle,
+c    .                                                    varunits)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = (rain_fall(i) + snow_fall(i))* 86400.
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"rain",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'rain',zx_tmp_fi2d,
+c    .              'Precipitation','mm/day')
+
+
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite(nid_day,"snow",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'snow',snow_fall,
+c    .              'Snow','mm/day')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+      CALL histwrite(nid_day,"snow_cov",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'snow_cov',zxsnow,
+c    .              'Snow cover','mm')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_day,"evap",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'evap',evap,
+c    .              'Evaporation','mm/day')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite(nid_day,"tops",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tops',topsw,
+c    .              'Solar rad. at TOA','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_day,"topl",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'topl',toplw,
+c    .              'IR rad. at TOA','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_day,"sols",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'sols',solsw,
+c    .              'Solar rad. at surf.','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_day,"soll",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'soll',sollw,
+c    .              'IR rad. at surface','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite(nid_day,"solldown",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'solldown',sollwdown,
+c    .              'Down. IR rad. at surface','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite(nid_day,"bils",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'bils',bils,
+c    .              'Surf. total heat flux','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+      CALL histwrite(nid_day,"sens",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'sens',sens,
+c    .              'Sensible heat flux','W/m2')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite(nid_day,"fder",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'fder',fder,
+c    .              'Heat flux derivation','W/m2')
+c
+c
+      DO nsrf = 1, nbsrf
+C§§§
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"pourc_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'pourc_'//clnsurf(nsrf),
+c    .                pctsrf( 1 : klon, nsrf),
+c    .                'Fraction'//clnsurf(nsrf),'-')
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"tsol_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'tsol_'//clnsurf(nsrf),
+c    .                ftsol( 1 : klon, nsrf),
+c    .                'Surf. Temp'//clnsurf(nsrf),'K')
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"sens_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'sens_'//clnsurf(nsrf),
+c    .                fluxt( 1 : klon, 1, nsrf),
+c    .                'Sensible heat flux '//clnsurf(nsrf),'W/m2')
+C  
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"lat_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'lat_'//clnsurf(nsrf),
+c    .                fluxlat( 1 : klon, nsrf),
+c    .                'Latent heat flux '//clnsurf(nsrf),'W/m2')
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"taux_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'taux_'//clnsurf(nsrf),
+c    .                fluxu( 1 : klon, 1, nsrf),
+c    .                'Zonal wind stress '//clnsurf(nsrf),'Pa')
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"tauy_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+c       call writephy(fid_day,prof2d_av,'tauy_'//clnsurf(nsrf),
+c    .                fluxv( 1 : klon, 1, nsrf),
+c    .                'Meridional wind stress '//clnsurf(nsrf),'Pa')
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"albe_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'albe_'//clnsurf(nsrf),
+c    .                falbe( 1 : klon, nsrf),
+c    .                'Albedo surf. SW'//clnsurf(nsrf),'-')
+c       call writephy(fid_day,prof2d_av,'alblw_'//clnsurf(nsrf),
+c    .                falblw( 1 : klon, nsrf),
+c    .                'Albedo surf. LW'//clnsurf(nsrf),'-')
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_day,"rugs_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+c       call writephy(fid_day,prof2d_av,'rugs_'//clnsurf(nsrf),
+c    .                frugs( 1 : klon, nsrf),
+c    .                'Rugosity '//clnsurf(nsrf),' - ')
+C 
+      END DO  
+C
+c$$$      DO i = 1, klon
+c$$$         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+c$$$      ENDDO
+c$$$      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c$$$      CALL histwrite(nid_day,"sicf",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldl",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'cldl',cldl,
+c    .              'Low-level cloudiness','-')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldm",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'cldm',cldm,
+c    .              'Mid-level cloudiness','-')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldh",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'cldh',cldh,
+c    .              'High-level cloudiness','-')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldt",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'cldt',cldt,
+c    .              'Total cloudiness','-')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldq",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'cldq',cldq,
+c    .              'Cloud liquid water path','-')
+c
+c Champs 3D:
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"temp",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c Essai writephys
+      varname = 'temp'
+      vartitle= 'temperature 3D'
+      varunits= 'K'
+c     call writephy(fid_day,prof3d_av,varname,t_seri,vartitle,varunits)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite(nid_day,"ovap",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'ovap',qx(1,1,ivap),
+c    .              'Specific humidity','Kg/Kg')
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite(nid_day,"geop",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'geop',zphi,
+c    .              'Geopotential height','m')
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitu",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'vitu',u_seri,
+c    .              'Zonal wind','m/s')
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitv",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'vitv',v_seri,
+c    .              'Meridional wind','m/s')
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitw",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'vitw',omega,
+c    .              'Vertical wind','m/s')
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite(nid_day,"pres",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'pres',pplay,
+c    .              'Air pressure','Pa')
+
+c
+      if (ok_sync) then
+c       call writephy_sync(fid_day)
+        call histsync(nid_day)
+      endif
       ENDIF
-c
-c
-      IF (ok_journe) THEN
-c
-      ndex(1) = 0
+C
+      IF (ok_mensuel) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
 c
 c Champs 2D:
 c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxtsol,zx_tmp_2d)
-      CALL histwrite(nid_day,"tsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+         zsto = dtime
+         zout = dtime * ecrit_mth
+
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_mth,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+         CALL histwrite(nid_mth,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tsol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
 c
       DO i = 1, klon
          zx_tmp_fi2d(i) = paprs(i,1)
       ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_day,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"psol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"qsol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
 c
       DO i = 1, klon
          zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
       ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_day,"rain",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, snow_fall,zx_tmp_2d)
-      CALL histwrite(nid_day,"snow",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, evap,zx_tmp_2d)
-      CALL histwrite(nid_day,"evap",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw,zx_tmp_2d)
-      CALL histwrite(nid_day,"tops",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
-      CALL histwrite(nid_day,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw,zx_tmp_2d)
-      CALL histwrite(nid_day,"sols",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw,zx_tmp_2d)
-      CALL histwrite(nid_day,"soll",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, bils,zx_tmp_2d)
-      CALL histwrite(nid_day,"bils",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sens,zx_tmp_2d)
-      CALL histwrite(nid_day,"sens",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, fder,zx_tmp_2d)
-      CALL histwrite(nid_day,"fder",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ruis,zx_tmp_2d)
-      CALL histwrite(nid_day,"ruis",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = fluxu(i,1)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_day,"frtu",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = fluxv(i,1)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_day,"frtv",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_day,"sicf",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldl,zx_tmp_2d)
-      CALL histwrite(nid_day,"cldl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldm,zx_tmp_2d)
-      CALL histwrite(nid_day,"cldm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldh,zx_tmp_2d)
-      CALL histwrite(nid_day,"cldh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldt,zx_tmp_2d)
-      CALL histwrite(nid_day,"cldt",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldq,zx_tmp_2d)
-      CALL histwrite(nid_day,"cldq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"rain",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"plul",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"pluc",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite(nid_mth,"snow",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+      CALL histwrite(nid_mth,"snow_cov",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_mth,"evap",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite(nid_mth,"solldown",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops0",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl0",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols0",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll0",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite(nid_mth,"bils",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sens",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite(nid_mth,"fder",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxu(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtu",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c      DO i = 1, klon
+c         zx_tmp_fi2d(i) = fluxv(i,1)
+c      ENDDO
+c      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c      CALL histwrite(nid_mth,"frtv",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO nsrf = 1, nbsrf
+C§§§
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"pourc_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"tsol_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"sens_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"lat_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"taux_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"tauy_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+C 
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"albe_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_mth,"rugs_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, agesno,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ages_"//clnsurf(nsrf),itap
+     $    ,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      END DO  
+c$$$      DO i = 1, klon
+c$$$         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+c$$$      ENDDO
+c$$$      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+c$$$      CALL histwrite(nid_mth,"sicf",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"albs",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"albslw",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrm",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrh",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldl",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldm",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldh",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldt",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldq",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ue",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ve",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"uq",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"vq",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+cKE43
+      IF (iflag_con .EQ. 4) THEN ! sb
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cape",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite(nid_mth,"pbase",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_pct,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ptop",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1,ema_cbmf,zx_tmp_2d)
+      CALL histwrite(nid_mth,"fbase",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+      ENDIF
+c34EK
 c
 c Champs 3D:
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
-      CALL histwrite(nid_day,"temp",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,ivap), zx_tmp_3d)
-      CALL histwrite(nid_day,"ovap",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
-      CALL histwrite(nid_day,"geop",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
-      CALL histwrite(nid_day,"vitu",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
-      CALL histwrite(nid_day,"vitv",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, omega, zx_tmp_3d)
-      CALL histwrite(nid_day,"vitw",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
-      CALL histwrite(nid_day,"pres",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      if (ok_sync) call histsync
+C
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"temp",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite(nid_mth,"ovap",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
+      CALL histwrite(nid_mth,"geop",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitu",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitv",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, omega, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitw",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
+      CALL histwrite(nid_mth,"pres",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldfra, zx_tmp_3d)
+      CALL histwrite(nid_mth,"rneb",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zx_rh, zx_tmp_3d)
+      CALL histwrite(nid_mth,"rhum",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cldliq, zx_tmp_3d)
+      CALL histwrite(nid_mth,"oliq",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtdyn",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_dyn, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqdyn",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_con, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtcon",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_con, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqcon",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlsc",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqlsc",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_eva, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dteva",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_eva, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqeva",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ptconv",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ratqs",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtajs",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_ajs, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqajs",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtswr",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, heat0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtsw0",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlwr",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, cool0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlw0",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"duvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      IF (ok_orodr) THEN
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_oro, zx_tmp_3d)
+      CALL histwrite(nid_mth,"duoro",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_oro, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvoro",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
       ENDIF
 C
-      IF (ok_mensuel) THEN
-c
-      ndex(1) = 0
-c
-c Champs 2D:
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxtsol,zx_tmp_2d)
-      CALL histwrite(nid_mth,"tsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = paprs(i,1)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxqsol,zx_tmp_2d)
-      CALL histwrite(nid_mth,"qsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"rain",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"plul",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"pluc",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, snow_fall,zx_tmp_2d)
-      CALL histwrite(nid_mth,"snow",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, agesno,zx_tmp_2d)
-      CALL histwrite(nid_mth,"ages",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, evap,zx_tmp_2d)
-      CALL histwrite(nid_mth,"evap",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw,zx_tmp_2d)
-      CALL histwrite(nid_mth,"tops",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
-      CALL histwrite(nid_mth,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw,zx_tmp_2d)
-      CALL histwrite(nid_mth,"sols",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw,zx_tmp_2d)
-      CALL histwrite(nid_mth,"soll",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw0,zx_tmp_2d)
-      CALL histwrite(nid_mth,"tops0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw0,zx_tmp_2d)
-      CALL histwrite(nid_mth,"topl0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw0,zx_tmp_2d)
-      CALL histwrite(nid_mth,"sols0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw0,zx_tmp_2d)
-      CALL histwrite(nid_mth,"soll0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, bils,zx_tmp_2d)
-      CALL histwrite(nid_mth,"bils",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sens,zx_tmp_2d)
-      CALL histwrite(nid_mth,"sens",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, fder,zx_tmp_2d)
-      CALL histwrite(nid_mth,"fder",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ruis,zx_tmp_2d)
-      CALL histwrite(nid_mth,"ruis",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = fluxu(i,1)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"frtu",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = fluxv(i,1)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"frtv",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      DO i = 1, klon
-         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
-      ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_mth,"sicf",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, albsol,zx_tmp_2d)
-      CALL histwrite(nid_mth,"albs",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cdragm,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cdrm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cdragh,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cdrh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldl,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cldl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldm,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cldm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldh,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cldh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldt,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cldt",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldq,zx_tmp_2d)
-      CALL histwrite(nid_mth,"cldq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ue,zx_tmp_2d)
-      CALL histwrite(nid_mth,"ue",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ve,zx_tmp_2d)
-      CALL histwrite(nid_mth,"ve",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, uq,zx_tmp_2d)
-      CALL histwrite(nid_mth,"uq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, vq,zx_tmp_2d)
-      CALL histwrite(nid_mth,"vq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-c Champs 3D:
-C
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
-      CALL histwrite(nid_mth,"temp",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,ivap), zx_tmp_3d)
-      CALL histwrite(nid_mth,"ovap",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
-      CALL histwrite(nid_mth,"geop",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
-      CALL histwrite(nid_mth,"vitu",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
-      CALL histwrite(nid_mth,"vitv",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, omega, zx_tmp_3d)
-      CALL histwrite(nid_mth,"vitw",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
-      CALL histwrite(nid_mth,"pres",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cldfra, zx_tmp_3d)
-      CALL histwrite(nid_mth,"rneb",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zx_rh, zx_tmp_3d)
-      CALL histwrite(nid_mth,"rhum",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cldliq, zx_tmp_3d)
-      CALL histwrite(nid_mth,"oliq",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_dyn, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtdyn",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_qx_dyn(1,1,ivap),
-     .                 zx_tmp_3d)
-      CALL histwrite(nid_mth,"dqdyn",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_con, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtcon",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_con, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dqcon",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_lsc, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtlsc",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_lsc, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dqlsc",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_vdf, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtvdf",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_vdf, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dqvdf",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_eva, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dteva",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_eva, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dqeva",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-C      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_ajs, zx_tmp_3d)
-C      CALL histwrite(nid_mth,"dtajs",itap,zx_tmp_3d,
-C    .                                   iim*(jjm+1)*klev,ndex)
-c
-C      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_ajs, zx_tmp_3d)
-C      CALL histwrite(nid_mth,"dqajs",itap,zx_tmp_3d,
-C     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, heat, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtswr",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, heat0, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtsw0",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cool, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtlwr",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cool0, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dtlw0",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_vdf, zx_tmp_3d)
-      CALL histwrite(nid_mth,"duvdf",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_vdf, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dvvdf",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      IF (ok_orodr) THEN
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_oro, zx_tmp_3d)
-      CALL histwrite(nid_mth,"duoro",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_oro, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dvoro",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
+      IF (ok_orolf) THEN
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_lif, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dulif",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_v_lif, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvlif",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
       ENDIF
 C
-      IF (ok_orolf) THEN
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_lif, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dulif",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_lif, zx_tmp_3d)
-      CALL histwrite(nid_mth,"dvlif",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-      ENDIF
-C
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, wo, zx_tmp_3d)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
       CALL histwrite(nid_mth,"ozone",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
+     .                                   iim*jjmp1*klev,ndex3d)
 c
       IF (nqmax.GE.3) THEN
       DO iq=1,nqmax-2
       IF (iq.LE.99) THEN
-         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,iq+2), zx_tmp_3d)
+         CALL gr_fi_ecrit(klev,klon,iim,jjmp1, qx(1,1,iq+2), zx_tmp_3d)
          WRITE(str2,'(i2.2)') iq
          CALL histwrite(nid_mth,"trac"//str2,itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
+     .                                   iim*jjmp1*klev,ndex3d)
       ELSE
          PRINT*, "Trop de traceurs"
@@ -2246,126 +3071,207 @@
       ENDDO
       ENDIF
-c
-      if (ok_sync) call histsync
+cKE43
+      IF (iflag_con.EQ.4) THEN ! (sb)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite(nid_mth,"upwd",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dnwd",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, dnwd0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dnwd0",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, Ma, zx_tmp_3d)
+      CALL histwrite(nid_mth,"Ma",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+c
       ENDIF
+c34EK
+c
+      if (ok_sync) then
+        call histsync(nid_mth)
+      endif
+      ENDIF
 c
       IF (ok_instan) THEN
 c
-      ndex(1) = 0
+      ndex2d = 0
+      ndex3d = 0
 c
 c Champs 2D:
 c
+         zsto = dtime * ecrit_ins
+         zout = dtime * ecrit_ins
+
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_ins,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+         CALL histwrite(nid_ins,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+
       DO i = 1, klon
          zx_tmp_fi2d(i) = paprs(i,1)
       ENDDO
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
-      CALL histwrite(nid_ins,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
-c
-      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
-      CALL histwrite(nid_ins,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"psol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"rain",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"plul",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"pluc",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_ins,"tsol",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, snow_fall,zx_tmp_2d)
+      CALL histwrite(nid_ins,"snow",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"topl",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_ins,"evap",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"sols",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"soll",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite(nid_ins,"solldown",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite(nid_ins,"bils",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+      CALL histwrite(nid_ins,"sens",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite(nid_ins,"fder",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_oce),zx_tmp_2d)
+      CALL histwrite(nid_ins,"dtsvdfo",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_ter),zx_tmp_2d)
+      CALL histwrite(nid_ins,"dtsvdft",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_lic),zx_tmp_2d)
+      CALL histwrite(nid_ins,"dtsvdfg",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, d_ts(1,is_sic),zx_tmp_2d)
+      CALL histwrite(nid_ins,"dtsvdfi",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      DO nsrf = 1, nbsrf
+C§§§
+        zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"pourc_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C 
+        zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"sens_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"lat_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"tsol_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"taux_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C      
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"tauy_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"rugs_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C
+        zx_tmp_fi2d(1 : klon) = falbe( 1 : klon, nsrf)
+        CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d , zx_tmp_2d)
+        CALL histwrite(nid_ins,"albe_"//clnsurf(nsrf),itap,
+     $      zx_tmp_2d,iim*jjmp1,ndex2d) 
+C 
+      END DO  
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite(nid_ins,"albs",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"albslw",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+      CALL histwrite(nid_ins,"snow_cov",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
+      CALL histwrite(nid_ins,"rugs",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
 c
 c Champs 3D:
 c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
       CALL histwrite(nid_ins,"temp",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, u_seri, zx_tmp_3d)
       CALL histwrite(nid_ins,"vitu",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, v_seri, zx_tmp_3d)
       CALL histwrite(nid_ins,"vitv",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zphi, zx_tmp_3d)
       CALL histwrite(nid_ins,"geop",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, pplay, zx_tmp_3d)
       CALL histwrite(nid_ins,"pres",itap,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-c
-      if (ok_sync) call histsync
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite(nid_ins,"dtvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite(nid_ins,"dqvdf",itap,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+c
+      if (ok_sync) then
+        call histsync(nid_ins)
+      endif
       ENDIF
 c
-      IF (ok_oasis .AND. mod(itap,nexca).EQ.0) THEN
-c
-c Je ne traite pas le ruissellement, pour l'instant (qui m'aidera ?)
-         DO i = 1, klon
-            oas_ruisoce(i) = 0.0
-            oas_ruisriv(i) = 0.0
-         ENDDO
-c
-         ig = 1
-         DO i = 1, iim
-            z_sols(i,1) = oas_sols(ig)
-            z_nsol(i,1) = oas_nsol(ig)
-            z_rain(i,1) = oas_rain(ig)
-            z_snow(i,1) = oas_snow(ig)
-            z_evap(i,1) = oas_evap(ig)
-            z_ruisoce(i,1) = oas_ruisoce(ig)
-            z_ruisriv(i,1) = oas_ruisriv(ig)
-            z_tsol(i,1) = oas_tsol(ig)
-            z_fder(i,1) = oas_fder(ig)
-            z_albe(i,1) = oas_albe(ig)
-            z_taux(i,1) = oas_taux(ig)
-            z_tauy(i,1) = oas_tauy(ig)
-         ENDDO
-         DO j = 2, jjm
-         DO i = 1, iim
-            ig = ig + 1
-            z_sols(i,j) = oas_sols(ig)
-            z_nsol(i,j) = oas_nsol(ig)
-            z_rain(i,j) = oas_rain(ig)
-            z_snow(i,j) = oas_snow(ig)
-            z_evap(i,j) = oas_evap(ig)
-            z_ruisoce(i,j) = oas_ruisoce(ig)
-            z_ruisriv(i,j) = oas_ruisriv(ig)
-            z_tsol(i,j) = oas_tsol(ig)
-            z_fder(i,j) = oas_fder(ig)
-            z_albe(i,j) = oas_albe(ig)
-            z_taux(i,j) = oas_taux(ig)
-            z_tauy(i,j) = oas_tauy(ig)
-         ENDDO
-         ENDDO
-         ig = ig + 1
-         DO i = 1, iim
-            z_sols(i,jjm+1)    = oas_sols(ig)
-            z_nsol(i,jjm+1)    = oas_nsol(ig)
-            z_rain(i,jjm+1)    = oas_rain(ig)
-            z_snow(i,jjm+1)    = oas_snow(ig)
-            z_evap(i,jjm+1)    = oas_evap(ig)
-            z_ruisoce(i,jjm+1) = oas_ruisoce(ig)
-            z_ruisriv(i,jjm+1) = oas_ruisriv(ig)
-            z_tsol(i,jjm+1)    = oas_tsol(ig)
-            z_fder(i,jjm+1)    = oas_fder(ig)
-            z_albe(i,jjm+1)    = oas_albe(ig)
-            z_taux(i,jjm+1)    = oas_taux(ig)
-            z_tauy(i,jjm+1)    = oas_tauy(ig)
-         ENDDO
-c
-c Passer les champs au coupleur:
-c
-         CALL intocpl(itap,(jjm+1)*iim,
-     .                   z_sols, z_nsol,
-     .                   z_rain, z_snow, z_evap,
-     .                   z_ruisoce, z_ruisriv,
-     .                   z_tsol, z_fder, z_albe,
-     .                   z_taux, z_tauy)
-         DO i = 1, klon
-           oas_sols(i) = 0.0
-           oas_nsol(i) = 0.0
-           oas_rain(i) = 0.0
-           oas_snow(i) = 0.0
-           oas_evap(i) = 0.0
-           oas_ruis(i) = 0.0
-           oas_tsol(i) = 0.0
-           oas_fder(i) = 0.0
-           oas_albe(i) = 0.0
-           oas_taux(i) = 0.0
-           oas_tauy(i) = 0.0
-         ENDDO
-      ENDIF
 c
 c Ecrire la bande regionale (binaire grads)
@@ -2383,6 +3289,6 @@
          CALL ecriregs(84,bils)
          CALL ecriregs(84,pctsrf(1,is_sic))
-         CALL ecriregs(84,fluxu(1,1))
-         CALL ecriregs(84,fluxv(1,1))
+         CALL ecriregs(84,zxfluxu(1,1))
+         CALL ecriregs(84,zxfluxv(1,1))
          CALL ecriregs(84,ue)
          CALL ecriregs(84,ve)
@@ -2433,4 +3339,13 @@
       ENDIF
 c
+c Sauvegarder les valeurs de t et q a la fin de la physique:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_ancien(i,k) = t_seri(i,k)
+         q_ancien(i,k) = q_seri(i,k)
+      ENDDO
+      ENDDO
+c
 c====================================================================
 c Si c'est la fin, il faut conserver l'etat de redemarrage
@@ -2438,14 +3353,17 @@
 c
       IF (lafin) THEN
-         IF (ok_oasis) CALL quitcpl
+ccc         IF (ok_oasis) CALL quitcpl
          CALL phyredem ("restartphy.nc",dtime,radpas,co2_ppm,solaire,
-     .        rlat,rlon,ftsol,ftsoil,deltat,fqsol,fsnow,
-     .        radsol,rugmer,agesno,
-     .        zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro)
+     .      rlat, rlon, pctsrf, ftsol, ftsoil, deltat, fqsol, fsnow,
+     .      falbe, fevap, rain_fall, snow_fall,
+     .      solsw, sollwdown,dlw,
+     .      radsol,frugs,agesno,
+     .      zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,
+     .      t_ancien, q_ancien)
       ENDIF
 
       RETURN
       END
-      SUBROUTINE qcheck(klon,klev,paprs,q,ql,marque)
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
       IMPLICIT none
 c
@@ -2456,18 +3374,23 @@
       INTEGER klon,klev
       REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
-      CHARACTER *(*) marque
-      REAL qtotal
+      REAL aire(klon)
+      REAL qtotal, zx, qcheck
       INTEGER i, k
 c
+      zx = 0.0
+      DO i = 1, klon
+         zx = zx + aire(i)
+      ENDDO
       qtotal = 0.0
       DO k = 1, klev
       DO i = 1, klon
-         qtotal = qtotal + (q(i,k)+ql(i,k))
+         qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)
      .                     *(paprs(i,k)-paprs(i,k+1))/RG
       ENDDO
       ENDDO
 c
-      PRINT*, "Eau totale ",marque, qtotal/FLOAT(klon)
-c
+      qcheck = qtotal/zx
+c
+      RETURN
       END
       SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
@@ -2478,21 +3401,19 @@
 c
       INTEGER nfield,nlon,iim,jjmp1, jjm
-      REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield)
-c
-      INTEGER i, j, n, ig
+      REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+c
+      INTEGER i, n, ig
 c
       jjm = jjmp1 - 1
       DO n = 1, nfield
          DO i=1,iim
-            ecrit(i,1,n) = fi(1,n)
-            ecrit(i,jjm+1,n) = fi(nlon,n)
+            ecrit(i,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
          ENDDO
-         DO j = 2, jjm
-            ig = 2+(j-2)*iim
-            DO i = 1, iim
-               ecrit(i,j,n) = fi(ig-1+i,n)
-            ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
          ENDDO
       ENDDO
       RETURN
       END
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/phystoke.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phystoke.F	(revision 3)
+++ 	(revision )
@@ -1,214 +1,0 @@
-      SUBROUTINE phystoke (
-     I                   nlon,nlev,pdtphys,
-     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
-     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
-     I                   frac_impa,frac_nucl)
-      IMPLICIT none
-
-c======================================================================
-c Auteur(s) FH
-c Objet: Moniteur general des tendances traceurs
-c
-
-c======================================================================
-#include "dimensions.h"
-#include "dimphy.h"
-#include "tracstoke.h"
-#include "indicesol.h"
-c======================================================================
-
-c Arguments:
-c
-c   EN ENTREE:
-c   ==========
-c
-c   divers:
-c   -------
-c
-      integer nlon ! nombre de points horizontaux
-      integer nlev ! nombre de couches verticales
-      real pdtphys ! pas d'integration pour la physique (seconde)
-c
-c   convection:
-c   -----------
-c
-      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
-      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
-      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
-      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
-      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
-      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
-c
-c   Couche limite:
-c   --------------
-c
-      REAL pcoefh(klon,klev)    ! coeff melange CL
-      REAL yv1(klon)
-      REAL yu1(klon)
-c
-c   Lessivage:
-c   ----------
-c
-      REAL frac_impa(klon,klev)
-      REAL frac_nucl(klon,klev)
-c
-c Arguments necessaires pour les sources et puits de traceur
-C
-      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
-      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
-
-c======================================================================
-c
-      INTEGER i, k
-c
-      REAL mfu(klon,klev)  ! flux de masse dans le panache montant
-      REAL mfd(klon,klev)  ! flux de masse dans le panache descendant
-      REAL en_u(klon,klev) ! flux entraine dans le panache montant
-      REAL de_u(klon,klev) ! flux detraine dans le panache montant
-      REAL en_d(klon,klev) ! flux entraine dans le panache descendant
-      REAL de_d(klon,klev) ! flux detraine dans le panache descendant
-      REAL coefh(klon,klev) ! flux detraine dans le panache descendant
-
-      REAL pyu1(klon),pyv1(klon)
-      REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
-
-      REAL dtcum
-
-      integer iadvtr,irec
-      real zmin,zmax
-
-      save mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
-      save iadvtr,irec
-      save pyu1,pyv1,pftsol,ppsrf
-
-      data iadvtr,irec/0,1/
-c
-c   Couche limite:
-c======================================================================
-
-      print*,'iadvtr= ',iadvtr
-      print*,'istphy= ',istphy
-      print*,'istdyn= ',istdyn
-
-      IF (iadvtr.eq.0) THEN
-#ifdef CRAY
-         CALL ASSIGN("assign -N ieee -F null f:physique")
-#endif
-         open(49,file='physique',form='unformatted',
-     s        access='direct',recl=4*klon*(9*klev+2+2*nbsrf))
-      ENDIF
-c
-      iadvtr=iadvtr+1
-c
-      IF(mod(iadvtr,istphy).eq.0) THEN 
-c
-c   normalisation par le temps cumule
-         do k=1,klev
-            do i=1,klon
-               mfu(i,k)=mfu(i,k)/dtcum
-               mfd(i,k)=mfd(i,k)/dtcum
-               en_u(i,k)=en_u(i,k)/dtcum
-               de_u(i,k)=de_u(i,k)/dtcum
-               en_d(i,k)=en_d(i,k)/dtcum
-               de_d(i,k)=de_d(i,k)/dtcum
-               coefh(i,k)=coefh(i,k)/dtcum
-            enddo
-         enddo
-         do i=1,klon
-            pyv1(i)=pyv1(i)/dtcum
-            pyu1(i)=pyu1(i)/dtcum
-         end do
-         do k=1,nbsrf
-             do i=1,klon
-               pftsol(i,k)=pftsol(i,k)/dtcum
-               ppsrf(i,k)=ppsrf(i,k)/dtcum
-            enddo
-         enddo
-c
-c   ecriture des champs
-c
-         irec=irec+1
-         write(49,rec=1) float(irec),float(istphy),
-     s    float(klon),float(klev)
-         write(49,rec=irec) mfu,mfd,en_u,de_u,en_d,de_d
-     s        ,coefh
-     s        ,frac_impa,frac_nucl
-     s        ,pyu1,pyv1,pftsol,ppsrf
-c
-cAA Test sur la valeur des coefficients de lessivage 
-c
-         zmin=1e33
-         zmax=-1e33
-         do k=1,klev
-            do i=1,klon
-                  zmax=max(zmax,frac_nucl(i,k))
-                  zmin=min(zmin,frac_nucl(i,k))
-            enddo
-         enddo
-         Print*,'------ coefs de lessivage (min et max) --------'
-         Print*,'facteur de nucleation ',zmin,zmax
-         zmin=1e33
-         zmax=-1e33
-         do k=1,klev
-            do i=1,klon
-                  zmax=max(zmax,frac_impa(i,k))
-                  zmin=min(zmin,frac_impa(i,k))
-            enddo
-         enddo
-         Print*,'facteur d impaction ',zmin,zmax
-
-      ENDIF 
-
-c   reinitialisation des champs cumules
-      if (mod(iadvtr,istphy).eq.1) then
-         do k=1,klev
-            do i=1,klon
-               mfu(i,k)=0.
-               mfd(i,k)=0.
-               en_u(i,k)=0.
-               de_u(i,k)=0.
-               en_d(i,k)=0.
-               de_d(i,k)=0.
-               coefh(i,k)=0.
-            enddo
-         enddo
-         do i=1,klon
-            pyv1(i)=0.
-            pyu1(i)=0.
-         end do
-         do k=1,nbsrf
-             do i=1,klon
-               pftsol(i,k)=0.
-               ppsrf(i,k)=0.
-            enddo
-         enddo
-
-         dtcum=0.
-      endif
-
-      do k=1,klev
-         do i=1,klon
-            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
-            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
-            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
-            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
-            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
-            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
-            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
-         enddo
-      enddo
-         do i=1,klon
-            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
-            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
-         end do
-         do k=1,nbsrf
-             do i=1,klon
-               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
-               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
-            enddo
-         enddo
-
-      dtcum=dtcum+pdtphys
-
-      RETURN
-      END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/phystokenc.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/phystokenc.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/phystokenc.F	(revision 300)
@@ -0,0 +1,342 @@
+c
+c $Header$
+c
+      SUBROUTINE phystokenc (
+     I                   nlon,nlev,pdtphys,rlon,rlat,
+     I                   pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
+     I                   pfrac_impa,pfrac_nucl,
+     I                   pphis,paire,dtime,itap)
+      USE ioipsl
+      USE histcom
+
+      IMPLICIT none
+
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+#include "control.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon ! nombre de points horizontaux
+      integer nlev ! nombre de couches verticales
+      real pdtphys ! pas d'integration pour la physique (seconde)
+c
+      integer physid, itap,ndex(1)
+
+c   convection:
+c   -----------
+c
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+	REAL pt(klon,klev)
+c
+      REAL rlon(klon), rlat(klon), dtime
+      REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
+
+c   Couche limite:
+c   --------------
+c
+      REAL pcoefh(klon,klev)    ! coeff melange CL
+      REAL yv1(klon)
+      REAL yu1(klon),pphis(klon),paire(klon)
+c
+c   Lessivage:
+c   ----------
+c
+      REAL pfrac_impa(klon,klev)
+      REAL pfrac_nucl(klon,klev)
+c
+c Arguments necessaires pour les sources et puits de traceur
+C
+      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+c======================================================================
+c
+      INTEGER i, k
+c
+      REAL mfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL mfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL en_u(klon,klev) ! flux entraine dans le panache montant
+      REAL de_u(klon,klev) ! flux detraine dans le panache montant
+      REAL en_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL de_d(klon,klev) ! flux detraine dans le panache descendant
+      REAL coefh(klon,klev) ! flux detraine dans le panache descendant
+	REAL t(klon,klev)
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+      REAL rain(klon)
+
+      REAL pyu1(klon),pyv1(klon)
+      REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
+      real pftsol1(klon),pftsol2(klon),pftsol3(klon),pftsol4(klon)
+      real ppsrf1(klon),ppsrf2(klon),ppsrf3(klon),ppsrf4(klon)
+
+      REAL dtcum
+
+      integer iadvtr,irec
+      real zmin,zmax
+
+      save t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
+      save iadvtr,irec
+      save frac_impa,frac_nucl,rain
+      save pyu1,pyv1,pftsol,ppsrf
+
+      data iadvtr,irec/0,1/
+c
+c   Couche limite:
+c======================================================================
+
+      print*,'iadvtr= ',iadvtr
+      print*,'istphy= ',istphy
+      print*,'istdyn= ',istdyn
+
+      IF (iadvtr.eq.0) THEN
+	
+	CALL initphysto('phystoke',
+     . rlon,rlat,dtime, dtime*istphy,dtime*istphy,nqmx,physid)
+  	
+	write(*,*) 'apres initphysto ds phystokenc' 
+
+       ndex(1) = 0
+         i=itap 
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+         CALL histwrite(physid,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+         i=itap
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+         CALL histwrite(physid,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+	
+      ENDIF
+c
+      iadvtr=iadvtr+1
+c
+c
+c   reinitialisation des champs cumules
+      if (mod(iadvtr,istphy).eq.1.or.istphy.eq.1) then
+	print*,'reinitialisation des champs cumules 
+     s          a iadvtr=',iadvtr
+         do k=1,klev
+            do i=1,klon
+               frac_impa(i,k)=1.
+               frac_nucl(i,k)=1.
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+		t(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            rain(i)=0.
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            frac_impa(i,k)=frac_impa(i,k)*pfrac_impa(i,k)
+            frac_nucl(i,k)=frac_nucl(i,k)*pfrac_nucl(i,k)
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+		t(i,k)=t(i,k)+pt(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+c
+      IF(mod(iadvtr,istphy).eq.0) THEN
+c
+c   normalisation par le temps cumule
+         do k=1,klev
+            do i=1,klon
+c              frac_impa=frac_impa : c'est la fraction cumulee qu'on stoke
+c              frac_nucl=frac_nucl : c'est la fraction cumulee qu'on stoke
+               mfu(i,k)=mfu(i,k)/dtcum
+               mfd(i,k)=mfd(i,k)/dtcum
+               en_u(i,k)=en_u(i,k)/dtcum
+               de_u(i,k)=de_u(i,k)/dtcum
+               en_d(i,k)=en_d(i,k)/dtcum
+               de_d(i,k)=de_d(i,k)/dtcum
+               coefh(i,k)=coefh(i,k)/dtcum
+		t(i,k)=t(i,k)/dtcum
+            enddo
+         enddo
+         do i=1,klon
+            rain(i)=rain(i)/dtcum
+            pyv1(i)=pyv1(i)/dtcum
+            pyu1(i)=pyu1(i)/dtcum
+         end do
+c modif abderr 23 11 00         do k=1,nbsrf
+             do i=1,klon
+	      do k=1,nbsrf
+               pftsol(i,k)=pftsol(i,k)/dtcum
+	       ppsrf(i,k)=ppsrf(i,k)/dtcum
+	      enddo
+               pftsol1(i) = pftsol(i,1)
+               pftsol2(i) = pftsol(i,2)
+               pftsol3(i) = pftsol(i,3)
+               pftsol4(i) = pftsol(i,4)
+
+c               ppsrf(i,k)=ppsrf(i,k)/dtcum
+               ppsrf1(i) = ppsrf(i,1)
+               ppsrf2(i) = ppsrf(i,2)
+               ppsrf3(i) = ppsrf(i,3)
+               ppsrf4(i) = ppsrf(i,4)
+
+            enddo
+c         enddo
+c
+c   ecriture des champs
+c
+         irec=irec+1
+
+ccccc
+      print*,'AVANT ECRITURE'
+         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t, zx_tmp_3d)
+         CALL histwrite(physid,"t",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+      print*,'APRES ECRITURE'
+
+         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfu, zx_tmp_3d)
+      CALL histwrite(physid,"mfu",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, mfd, zx_tmp_3d)
+      CALL histwrite(physid,"mfd",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_u, zx_tmp_3d)
+      CALL histwrite(physid,"en_u",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_u, zx_tmp_3d)
+      CALL histwrite(physid,"de_u",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, en_d, zx_tmp_3d)
+      CALL histwrite(physid,"en_d",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, de_d, zx_tmp_3d)
+      CALL histwrite(physid,"de_d",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1, coefh, zx_tmp_3d)
+      CALL histwrite(physid,"coefh",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+cccc
+       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_impa,zx_tmp_3d)
+        CALL histwrite(physid,"frac_impa",itap,zx_tmp_3d,
+     .  iim*(jjm+1)*klev,ndex)
+
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,frac_nucl,zx_tmp_3d)
+        CALL histwrite(physid,"frac_nucl",itap,zx_tmp_3d,
+     .  iim*(jjm+1)*klev,ndex)
+
+        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyu1,zx_tmp_2d)
+      CALL histwrite(physid,"pyu1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+
+        CALL gr_fi_ecrit(1, klon,iim,jjm+1, pyv1,zx_tmp_2d)
+      CALL histwrite(physid,"pyv1",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol1, zx_tmp_2d)
+      CALL histwrite(physid,"ftsol1",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol2, zx_tmp_2d)
+      CALL histwrite(physid,"ftsol2",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol3, zx_tmp_2d)
+      CALL histwrite(physid,"ftsol3",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1, pftsol4, zx_tmp_2d)
+      CALL histwrite(physid,"ftsol4",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, rain, zx_tmp_2d)
+      CALL histwrite(physid,"rain",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf1, zx_tmp_2d)
+      CALL histwrite(physid,"psrf1",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf2, zx_tmp_2d)
+      CALL histwrite(physid,"psrf2",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf3, zx_tmp_2d)
+      CALL histwrite(physid,"psrf3",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+        CALL gr_fi_ecrit(1,klon,iim,jjm+1, ppsrf4, zx_tmp_2d)
+      CALL histwrite(physid,"psrf4",itap,zx_tmp_2d,
+     .                                   iim*(jjm+1),ndex)
+
+c
+cAA Test sur la valeur des coefficients de lessivage
+c
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_nucl(i,k))
+                  zmin=min(zmin,frac_nucl(i,k))
+            enddo
+         enddo
+         Print*,'------ coefs de lessivage (min et max) --------'
+         Print*,'facteur de nucleation ',zmin,zmax
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_impa(i,k))
+                  zmin=min(zmin,frac_impa(i,k))
+            enddo
+         enddo
+         Print*,'facteur d impaction ',zmin,zmax
+
+      ENDIF
+
+
+      RETURN
+      END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/phytrac.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phytrac.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/phytrac.F	(revision 300)
@@ -1,4 +1,7 @@
+c
+c $Header$
+c
       SUBROUTINE phytrac (rnpb,
-     I                   debutphy,
+     I                   debutphy,lafin,
      I                   nqmax,
      I                   nlon,nlev,pdtphys,
@@ -10,4 +13,6 @@
      O                   tr_seri)
       USE ioipsl
+      USE histcom
+
       IMPLICIT none
 c======================================================================
@@ -27,4 +32,5 @@
 #include "dimphy.h"
 #include "indicesol.h"
+#include "temps.h"
 #include "control.h"
 c======================================================================
@@ -47,8 +53,9 @@
       real pplay(nlon,nlev)  ! pression pour le mileu de chaque couche (en Pa)
       real presnivs(klev) ! pressions approximat. des milieux couches ( en PA)
-      real znivsig(klev) ! niveaux sigma
       real paire(klon)
       real pphis(klon)
       logical debutphy       ! le flag de l'initialisation de la physique
+      logical lafin          ! le flag de la fin de la physique
+
       integer ll
 c
@@ -89,5 +96,8 @@
       real ftsol(nlon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
       real pctsrf(nlon,nbsrf) ! Pourcentage de sol f(nature du sol)
-
+c abder
+      real pftsol1(nlon),pftsol2(nlon),pftsol3(nlon),pftsol4(nlon)
+      real ppsrf1(nlon),ppsrf2(nlon),ppsrf3(nlon),ppsrf4(nlon)
+c fin
 cAA ----------------------------
 cAA  VARIABLES LOCALES TRACEURS
@@ -130,4 +140,5 @@
       INTEGER nid_tra
       SAVE nid_tra
+c     REAL x(klon,klev,nbtr+2) ! traceurs 
       INTEGER ndex(1)
       REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
@@ -140,4 +151,6 @@
       INTEGER ecrit_tra
       SAVE ecrit_tra   
+      logical ok_sync
+      parameter (ok_sync = .true.)
 C
 C nature du traceur
@@ -156,6 +169,6 @@
 c
 c--modif convection tiedtke
-      INTEGER i, k, it
-
+      INTEGER i, k, it,itap
+	save itap
       REAL delp(klon,klev)
 c--end modif
@@ -195,5 +208,6 @@
      s     inirnpb
       data first,couchelimite,convection,lessivage,sorties
-     s     /.true.,.true.,.true.,.true.,.true./
+c$$$ OM Test KE     s     /.true.,.true.,.true.,.true.,.true./
+     s     /.true.,.true.,.false.,.true.,.true./
 c
 c======================================================================
@@ -201,8 +215,11 @@
          modname='phytrac'
 
-         print*,'DANS PHYTRAC debutphy=',debutphy
-
-         ecrit_tra = NINT(86400./pdtphys *ecritphy)   
+c        print*,'DANS PHYTRAC debutphy=',debutphy
+
          if (debutphy) then
+
+          print*,'dans phytrac ',pdtphys,ecritphy,ecrit_tra
+          ecrit_tra = NINT(86400./pdtphys/2.) ! tous les 12H
+c         ecrit_tra = NINT(86400./pdtphys) ! tous les 24H
 
          if(nbtr.lt.nqmax) then
@@ -216,7 +233,8 @@
          PRINT*, 'La frequence de sortie traceurs est  ', ecrit_tra
          itra=0
+	 itap=0
 C         
-         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
-         zjulian = zjulian + dayref
+         CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ini
 c
          CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon)
@@ -225,16 +243,13 @@
             zx_lon(i,jjm+1) = xlon(i+1)
          ENDDO
-         DO ll=1,klev
-            znivsig(ll)=float(ll)
-         ENDDO
+c         DO ll=1,klev
+c            znivsig(ll)=float(ll)
+c         ENDDO
          CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat)
          CALL histbeg("histrac", iim,zx_lon, jjm+1,zx_lat,
      .                 1,iim,1,jjm+1, 0, zjulian, pdtphys,
      .                 nhori, nid_tra)
-         call histvert(nid_tra, 'sig_s', 'Niveaux sigma','-',
-     .              klev, znivsig, nvert)
-C
-C         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
-C     .                 klev, presnivs, nvert)
+         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
          zsto = pdtphys
          zout = pdtphys * FLOAT(ecrit_tra)
@@ -247,4 +262,66 @@
      .                iim,jjm+1,nhori, 1,1,1, -99, 32,
      .                "once",  zsto,zout)
+
+	goto 666
+         CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+
+         CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "psrf1", "nature sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "psrf2", "nature sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "psrf3", "nature sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "psrf4", "nature sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "ftsol1", "temper sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "ftsol2", "temper sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "ftsol3", "temper sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst",  zsto,zout)
+         CALL histdef(nid_tra, "ftsol4", "temper sol", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)",  zsto,zout)
+         CALL histdef(nid_tra, "pplay", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_tra, "t", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+         CALL histdef(nid_tra, "mfu", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "mfd", "flux u decen","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_u", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "en_d", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_u", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "de_d", "flux u mont","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         CALL histdef(nid_tra, "coefh", "turbulent coef","-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+666	continue
 c
          DO it=1,nqmax
@@ -275,5 +352,5 @@
          CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
          CALL histwrite(nid_tra,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
-c
+
 c======================================================================
 c   Initialisation de certaines variables pour le Rn et le Pb 
@@ -282,5 +359,5 @@
 c Initialisation du traceur dans le sol (couche limite radonique)
 c
-         print*,'valeur de debut dans phytrac :',debutphy
+c        print*,'valeur de debut dans phytrac :',debutphy
          do it=1,nqmax
             do i=1,klon
@@ -288,4 +365,11 @@
             enddo
          END DO
+
+         open (99,file='starttrac',status='old',
+     .         err=999,form='formatted')
+         read(99,*) (trs(i,1),i=1,klon)
+999      close(99)
+         print*, 'apres starttrac'
+
 c Initialisation de la fraction d'aerosols lessivee
 c
@@ -321,7 +405,71 @@
          inirnpb=.false.
       endif
+      if(nqmax.gt.2) aerosol(3)=.true.
+
+
+c  abder
+	goto 777
+            do i=1,nlon
+               pftsol1(i) = ftsol(i,1)
+               pftsol2(i) = ftsol(i,2)
+               pftsol3(i) = ftsol(i,3)
+               pftsol4(i) = ftsol(i,4)
+
+               ppsrf1(i) = pctsrf(i,1)
+               ppsrf2(i) = pctsrf(i,2)
+               ppsrf3(i) = pctsrf(i,3)
+               ppsrf4(i) = pctsrf(i,4)
+
+            enddo
+	 ndex(1)=0
+	 itap=itap+1
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,yu1,zx_tmp_2d)
+         CALL histwrite(nid_tra,"pyu1",itap,zx_tmp_2d,
+     s                                  iim*(jjm+1),ndex)
+         
+	 CALL gr_fi_ecrit(1,klon,iim,jjm+1,yv1,zx_tmp_2d)
+         CALL histwrite(nid_tra,"pyv1",itap,zx_tmp_2d,
+     s                                  iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol1,zx_tmp_2d)
+         CALL histwrite(nid_tra,"ftsol1",itap,zx_tmp_2d,
+     s                                       iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol2,zx_tmp_2d)
+         CALL histwrite(nid_tra,"ftsol2",itap,zx_tmp_2d,
+     s                                       iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol3,zx_tmp_2d)
+         CALL histwrite(nid_tra,"ftsol3",itap,zx_tmp_2d,
+     s                                      iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pftsol4,zx_tmp_2d)
+         CALL histwrite(nid_tra,"ftsol4",itap,zx_tmp_2d,
+     s                                      iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf1,zx_tmp_2d)
+         CALL histwrite(nid_tra,"psrf1",itap,zx_tmp_2d,
+     s                                     iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf2,zx_tmp_2d)
+         CALL histwrite(nid_tra,"psrf2",itap,zx_tmp_2d, 
+     s                                     iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf3,zx_tmp_2d)
+         CALL histwrite(nid_tra,"psrf3",itap,zx_tmp_2d,
+     s                                     iim*(jjm+1),ndex)
+
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,ppsrf4,zx_tmp_2d)
+         CALL histwrite(nid_tra,"psrf4",itap,zx_tmp_2d,
+     s                                     iim*(jjm+1),ndex)
+777	continue
 c======================================================================
 c   Calcul de l'effet de la convection
 c======================================================================
+	print*,'Avant convection'
+      do it=1,nqmax
+         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+      enddo
 
       if (convection) then
@@ -336,17 +484,26 @@
       ENDDO
       ENDDO
-      WRITE(itn,'(i1)') it
-      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it='//itn)
-      ENDDO
-      print*,'apres nflxtr'
+c      WRITE(itn,'(i1)') it
+c      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it='//itn)
+      ENDDO
+c      print*,'apres nflxtr'
 
 
       endif ! convection
+c        print*,'Apres convection'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant conv'//itn)
+c      enddo
 
 c======================================================================
 c   Calcul de l'effet de la couche limite
 c======================================================================
-
-      print*,'avant couchelimite'
+c	print *,'Avant couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
+
       if (couchelimite) then
 
@@ -359,5 +516,5 @@
 C maf modif pour tenir compte du cas rnpb + traceur
       DO it=1, nqmax
-      print *,'it',it,clsol(it)
+c     print *,'it',it,clsol(it)
       if (clsol(it)) then  ! couche limite avec quantite dans le sol calculee
           CALL cltracrn(it, pdtphys, yu1, yv1,
@@ -407,5 +564,9 @@
       endif ! couche limite
 
-      print*,'apres couchelimite'
+c      print*,'Apres couchelimite'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Avant CL  '//itn)
+c      enddo
 
 c======================================================================
@@ -436,7 +597,8 @@
 c======================================================================
 
+      print*,'LESSIVAGE =',lessivage
       IF (lessivage) THEN
 
-      print*,'avant lessivage'
+c     print*,'avant lessivage'
 
        DO it = 1, nqmax
@@ -468,14 +630,20 @@
 c Mise a jour due a l'impaction et a la nucleation
 c
+c      call dump2d(iim,jjm-1,frac_impa(2:klon-1,10),'FRACIMPA')
+c      call dump2d(iim,jjm-1,frac_nucl(2:klon-1,10),'FRACNUCL')
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3')
        DO it = 1, nqmax
+c         print*,'IT=',it,aerosol(it)
          IF (aerosol(it)) THEN
+c           print*,'IT=',it,' On lessive'
            DO k = 1, nlev
               DO i = 1, klon
-               tr_seri(i,k,it) = tr_seri(i,k,it) *
-     s              ( frac_impa(i,k) + frac_nucl(i,k) - 1. )    
+               tr_seri(i,k,it)=tr_seri(i,k,it)
+     s         *frac_impa(i,k)*frac_nucl(i,k)
               ENDDO
            ENDDO
          ENDIF
        ENDDO
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B')
 c
 c Flux lessivage total 
@@ -497,5 +665,5 @@
       ENDDO
 c
-      print*,'apres lessivage'
+c     print*,'apres lessivage'
       ENDIF
 Cc
@@ -519,9 +687,9 @@
        CALL histwrite(nid_tra,"tr"//str2,itra,zx_tmp_3d,
      .                                   iim*(jjm+1)*klev,ndex)
-       IF (lessivage) THEN
-       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
-       CALL histwrite(nid_tra,"fl"//str2,itra,zx_tmp_3d,
-     .                                   iim*(jjm+1)*klev,ndex)
-      ENDIF
+c      IF (lessivage) THEN
+c      CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
+c      CALL histwrite(nid_tra,"fl"//str2,itra,zx_tmp_3d,
+c    .                                   iim*(jjm+1)*klev,ndex)
+c     ENDIF
       ELSE
          PRINT*, "Trop de traceurs"
@@ -530,4 +698,55 @@
       ENDDO
 
+	goto 888
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pplay,zx_tmp_3d)
+        CALL histwrite(nid_tra,"pplay",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,t_seri,zx_tmp_3d)
+        CALL histwrite(nid_tra,"t",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfu,zx_tmp_3d)
+        CALL histwrite(nid_tra,"mfu",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pmfd,zx_tmp_3d)
+        CALL histwrite(nid_tra,"mfd",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_u,zx_tmp_3d)
+        CALL histwrite(nid_tra,"en_u",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pen_d,zx_tmp_3d)
+        CALL histwrite(nid_tra,"en_d",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_d,zx_tmp_3d)
+        CALL histwrite(nid_tra,"de_d",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,pde_u,zx_tmp_3d)
+        CALL histwrite(nid_tra,"de_u",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+        CALL gr_fi_ecrit(klev,klon,iim,jjm+1,coefh,zx_tmp_3d)
+        CALL histwrite(nid_tra,"coefh",itra,zx_tmp_3d,
+     .                  iim*(jjm+1)*klev,ndex)
+
+888	continue
+
+c	print*,'Sortie phytrac'
+c      do it=1,nqmax
+c         WRITE(itn,'(i1)') it
+c        call diagtracphy(tr_seri(:,:,it),paprs,'Fin Phys  '//itn)
+c      enddo
+
+      if (lafin) then
+         print*, 'c est la fin de la physique'
+         open (99,file='restarttrac',  form='formatted')
+         do i=1,klon
+             write(99,*) trs(i,1)
+         enddo
+         PRINT*, 'Ecriture du fichier restarttrac'
+         close(99)
+      else
+         print*, 'physique pas fini'
+      endif
+
+
       RETURN
       END
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.160.98.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.160.98.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.160.98.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=78,kflev=klev) ! 78*199
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.192.143.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.192.143.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.192.143.h	(revision 300)
@@ -0,0 +1,2 @@
+       INTEGER kdlon, kflev
+      PARAMETER (kdlon=10,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.32.24.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.32.24.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.32.24.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.48.32.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.48.32.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.48.32.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.72.46.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.72.46.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.72.46.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=1621,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.96.72.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.96.72.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.96.72.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=487,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.defaut.h
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.defaut.h	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.defaut.h	(revision 300)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/raddim.h	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/raddim.h	(revision 300)
@@ -1,2 +1,2 @@
       INTEGER kdlon, kflev
-      PARAMETER (kdlon=149,kflev=klev)
+      PARAMETER (kdlon=klon,kflev=klev)
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/radlwsw.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/radlwsw.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/radlwsw.F	(revision 300)
@@ -1,7 +1,8 @@
       SUBROUTINE radlwsw(dist, rmu0, fract, co2_ppm, solaire,
-     .                  paprs, pplay,tsol,albedo, t,q,wo,
+     .                  paprs, pplay,tsol,albedo, alblw, t,q,wo,
      .                  cldfra, cldemi, cldtau,
      .                  heat,heat0,cool,cool0,radsol,albpla,
      .                  topsw,toplw,solsw,sollw,
+     .                  sollwdown,
      .                  topsw0,toplw0,solsw0,sollw0)
       IMPLICIT none
@@ -44,5 +45,5 @@
 c
       real paprs(klon,klev+1), pplay(klon,klev)
-      real albedo(klon), tsol(klon)
+      real albedo(klon), alblw(klon), tsol(klon)
       real t(klon,klev), q(klon,klev), wo(klon,klev)
       real cldfra(klon,klev), cldemi(klon,klev), cldtau(klon,klev)
@@ -52,4 +53,5 @@
       real solsw(klon), sollw(klon), albpla(klon)
       real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      real sollwdown(klon)
 c
       REAL*8 zx_alpha1, zx_alpha2
@@ -83,4 +85,5 @@
       REAL*8 ztopsw(kdlon), ztoplw(kdlon)
       REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
+      REAL*8 zsollwdown(kdlon)
       REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
       REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
@@ -123,7 +126,9 @@
          zrmu0(i) = rmu0(iof+i)
          PALBD(i,1) = albedo(iof+i)
-         PALBD(i,2) = albedo(iof+i)
+!         PALBD(i,2) = albedo(iof+i)
+         PALBD(i,2) = alblw(iof+i)
          PALBP(i,1) = albedo(iof+i)
-         PALBP(i,2) = albedo(iof+i)
+!         PALBP(i,2) = albedo(iof+i)
+         PALBP(i,2) = alblw(iof+i)
          PEMIS(i) = 0.96
          PVIEW(i) = 1.66
@@ -186,5 +191,6 @@
      .        PVIEW,
      .        zcool, zcool0,
-     .        ztoplw,zsollw,ztoplw0,zsollw0)
+     .        ztoplw,zsollw,ztoplw0,zsollw0,
+     .        zsollwdown)
       CALL SW(PSCT, RCO2, zrmu0, zfract,
      S        PPMB, PDP,
@@ -201,4 +207,5 @@
          solsw(iof+i) = zsolsw(i)
          sollw(iof+i) = zsollw(i)
+         sollwdown(iof+i) = zsollwdown(i)
          topsw0(iof+i) = ztopsw0(i)
          toplw0(iof+i) = ztoplw0(i)
@@ -2454,5 +2461,6 @@
      .              PVIEW,
      .              PCOLR, PCOLR0,
-     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0)
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown)
       IMPLICIT none
 #include "dimensions.h"
@@ -2516,4 +2524,6 @@
       REAL*8 PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
       REAL*8 PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+c Rajout LF
+      real*8 psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
 C
 C-------------------------------------------------------------------------
@@ -2588,4 +2598,5 @@
          PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
          PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
       ENDDO
 C     ------------------------------------------------------------------
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke.F	(revision 300)
@@ -0,0 +1,431 @@
+c
+c $Header$
+c
+	subroutine read_pstoke(irec,
+     .   zrec,zklono,zklevo,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	
+	  integer*4 klono,klevo,imo,jmo
+	  parameter (imo=iim/2,jmo=(jjm+1)/2)
+	  parameter(klono=(jmo-1)*imo+2,klevo=llm)
+	  REAL*4 phisfi(klono)
+          REAL*4 phisfi2(imo,jmo+1),airefi2(imo,jmo+1)
+
+          REAL*4 mfu(klono,klevo), mfd(klono,klevo)
+          REAL*4 en_u(klono,klevo), de_u(klono,klevo)
+          REAL*4 en_d(klono,klevo), de_d(klono,klevo)
+          REAL*4 coefh(klono,klevo)
+
+          REAL*4 mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo)
+          REAL*4 en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo)
+          REAL*4 en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo)
+          REAL*4 coefh2(imo,jmo+1,klevo)
+
+          REAL*4 pl(klevo)
+          integer irec
+          integer*4 xid,yid,zid,tid
+          real zrec,zklono,zklevo,zim,zjm
+          integer*4 ncrec,ncklono,ncklevo,ncim,ncjm
+
+          real*4 airefi(klono)
+          character namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def klono
+c dim de phis??
+	  
+	 
+          REAL*4 frac_impa(klono,klevo), frac_nucl(klono,klevo)
+          REAL*4 frac_impa2(imo,jmo+1,klevo), 
+     .     frac_nucl2(imo,jmo+1,klevo)
+          REAL*4 pyu1(klono), pyv1(klono)
+          REAL*4 pyu12(imo,jmo+1), pyv12(imo,jmo+1)
+          REAL*4 ftsol(klono,nbsrf)
+          REAL*4 psrf(klono,nbsrf) 
+	  REAL*4 ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono)
+          REAL*4 psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono)
+          REAL*4 ftsol12(imo,jmo+1),ftsol22(imo,jmo+1),
+     .     ftsol32(imo,jmo+1),
+     .     ftsol42(imo,jmo+1)
+          REAL*4 psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1),
+     .     psrf42(imo,jmo+1)
+		REAL*4 t(klono,klevo)
+		REAL*4 t2(imo,jmo+1)	
+	  integer ncidp
+          save ncidp
+		integer varidt
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+          integer varidend,varidded,varidch,varidfi,varidfn
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+          save varidend,varidded,varidch,varidfi,varidfn
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+		save varidt
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+	        varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,ncklevo)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zklevo=ncklevo
+            zim=ncim
+            zjm=ncjm
+	
+	    zklono=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : zklevo = ', zklevo
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : zklono = ', zklono
+
+c niveaux de pression
+
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl)
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c phis
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,phisfi2)
+c      call dump2d(iip1-1,jjp1,phisfi2,'PHISNC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi)
+
+c aire
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+c      call correctbid(iim,jjp1*1,airefi2)
+c       call dump2d(iip1-1,jjp1,airefi2,'AIRENC')
+       call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=zklevo
+      count(4)=1
+
+c frac_impa 
+
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,frac_impa2)
+c      call dump2d(iip1-1,jjp1,frac_impa2,'FINC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,frac_nucl2)
+c      call dump2d(iip1-1,jjp1,frac_nucl2,'FINC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl)
+
+c abder t
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t)
+
+c mfu
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,mfu2)
+c      call dump2d(iip1-1,jjp1,mfu2,'MFUNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu)
+
+c mfd
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,mfd2)
+c      call dump2d(iip1-1,jjp1,mfd2,'MFDNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd)
+
+c en_u 
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,en_u2)
+c      call dump2d(iip1-1,jjp1,en_u2,'ENUNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u)
+
+c de_u 
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,de_u2)
+c      call dump2d(iip1-1,jjp1,de_u2,'DEUNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u)
+
+c en_d 
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,en_d2)
+c      call dump2d(iip1-1,jjp1,en_d2,'ENDNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d)
+
+c de_d 
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,de_d2)
+c      call dump2d(iip1-1,jjp1,de_d2,'DEDNC COUCHE 1')
+      call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d)
+
+c coefh 
+      status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*klevo,coefh2)
+c      call dump2d(iip1-1,jjp1,coefh2,'CHNC COUCHE 1')
+       call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh)
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,pyu12)
+c      call dump2d(iip1-1,jjp1,pyu12,'PYU1NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1)
+
+c pyv1
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,pyv12)
+c      call dump2d(iip1-1,jjp1,pyv12,'PYV1NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1)
+
+c ftsol1
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,ftsol12)
+c      call dump2d(iip1-1,jjp1,ftsol12,'FTS1NC')
+       call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1)
+
+c ftsol2
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,ftsol22)
+c      call dump2d(iip1-1,jjp1,ftsol22,'FTS2NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2)
+
+c ftsol3
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,ftsol32)
+c      call dump2d(iip1-1,jjp1,ftsol32,'FTS3NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3)
+
+c ftsol4
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,ftsol42)
+c      call dump2d(iip1-1,jjp1,ftsol42,'FTS4NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4)
+
+c psrf1 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,psrf12)
+c      call dump2d(iip1-1,jjp1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1)
+
+c psrf2 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,psrf22)
+c      call dump2d(iip1-1,jjp1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2)
+
+c psrf3 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,psrf32)
+c      call dump2d(iip1-1,jjp1,psrf32,'PSRF3NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3)
+
+c psrf4 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+c      print*,'WARNING!!! Correction bidon pour palier a un '
+c      print*,'probleme dans la creation des fichiers nc'
+c      call correctbid(iim,jjp1*1,psrf42)
+c      call dump2d(iip1-1,jjp1,psrf42,'PSRF4NC')
+      call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4)
+	
+          do i = 1,klono
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke0.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke0.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/read_pstoke0.F	(revision 300)
@@ -0,0 +1,358 @@
+c
+c $Header$
+c
+	subroutine read_pstoke0(irec,
+     .   zrec,zkon,zkev,airefi,phisfi,
+     .   t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
+     .   frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
+
+
+       IMPLICIT NONE
+
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "indicesol.h"
+#include "control.h"
+#include "dimphy.h"
+	  
+	  integer*4 kon,kev,zkon,zkev
+	  parameter(kon=iim*(jjm-1)+2,kev=llm)
+	  REAL*4 phisfi(kon)
+          REAL*4 phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
+
+          REAL*4 mfu(kon,kev), mfd(kon,kev)
+          REAL*4 en_u(kon,kev), de_u(kon,kev)
+          REAL*4 en_d(kon,kev), de_d(kon,kev)
+          REAL*4 coefh(kon,kev)
+		REAL*4 t(kon,kev)
+
+          REAL*4 mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
+          REAL*4 en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
+          REAL*4 en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
+          REAL*4 coefh2(iim,jjm+1,kev)
+		REAL*4 t2(iim,jjm+1,kev)
+
+          REAL*4 pl(kev)
+          integer irec
+          integer*4 xid,yid,zid,tid
+          integer*4 zrec,zim,zjm
+          integer*4 ncrec,nckon,nckev,ncim,ncjm
+
+          real*4 airefi(kon)
+          character namedim
+
+c  !! attention !!
+c attention il y a aussi le pb de def kon
+c dim de phis??
+
+          REAL*4 frac_impa(kon,kev), frac_nucl(kon,kev)
+          REAL*4 frac_impa2(iim,jjm+1,kev), 
+     .     frac_nucl2(iim,jjm+1,kev)
+          REAL*4 pyu1(kon), pyv1(kon)
+          REAL*4 pyu12(iim,jjm+1), pyv12(iim,jjm+1)
+          REAL*4 ftsol(kon,nbsrf)
+          REAL*4 psrf(kon,nbsrf) 
+	  REAL*4 ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
+          REAL*4 psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
+          REAL*4 ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
+     .     ftsol32(iim,jjm+1),
+     .     ftsol42(iim,jjm+1)
+          REAL*4 psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
+     .     psrf42(iim,jjm+1)
+	
+	  integer ncidp
+          save ncidp
+          integer varidmfu, varidmfd, varidps, varidenu, variddeu	
+		integer varidt
+          integer varidend,varidded,varidch,varidfi,varidfn
+          integer varidyu1,varidyv1,varidpl,varidai,varididvt
+          integer varidfts1,varidfts2,varidfts3,varidfts4
+          integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
+          save varidmfu, varidmfd, varidps, varidenu, variddeu
+		save varidt
+          save varidend,varidded,varidch,varidfi,varidfn
+          save varidyu1,varidyv1,varidpl,varidai,varididvt
+          save varidfts1,varidfts2,varidfts3,varidfts4
+          save varidpsr1,varidpsr2,varidpsr3,varidpsr4
+
+          integer l, i
+          integer start(4),count(4),status
+          real rcode
+          logical first
+          save first
+          data first/.true./
+
+
+
+c ---------------------------------------------
+c   Initialisation de la lecture des fichiers
+c ---------------------------------------------
+
+      if (irec .eq. 0) then
+
+            ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
+
+            varidps=NCVID(ncidp,'phis',rcode)
+            print*,'ncidp,varidps',ncidp,varidps
+
+            varidpl=NCVID(ncidp,'sig_s',rcode)
+            print*,'ncidp,varidpl',ncidp,varidpl
+
+            varidai=NCVID(ncidp,'aire',rcode)
+            print*,'ncidp,varidai',ncidp,varidai
+
+            varidmfu=NCVID(ncidp,'mfu',rcode)
+            print*,'ncidp,varidmfu',ncidp,varidmfu
+
+		varidt=NCVID(ncidp,'t',rcode)
+                print*,'ncidp,varidt',ncidp,varidt
+
+            varidmfd=NCVID(ncidp,'mfd',rcode)
+            print*,'ncidp,varidmfd',ncidp,varidmfd
+
+            varidenu=NCVID(ncidp,'en_u',rcode)
+            print*,'ncidp,varidenu',ncidp,varidenu
+
+            variddeu=NCVID(ncidp,'de_u',rcode)
+            print*,'ncidp,variddeu',ncidp,variddeu
+
+            varidend=NCVID(ncidp,'en_d',rcode)
+            print*,'ncidp,varidend',ncidp,varidend
+	
+            varidded=NCVID(ncidp,'de_d',rcode)
+            print*,'ncidp,varidded',ncidp,varidded
+	
+            varidch=NCVID(ncidp,'coefh',rcode)
+            print*,'ncidp,varidch',ncidp,varidch
+	
+	    varidfi=NCVID(ncidp,'frac_impa',rcode)
+            print*,'ncidp,varidfi',ncidp,varidfi
+	
+	    varidfn=NCVID(ncidp,'frac_nucl',rcode)
+            print*,'ncidp,varidfn',ncidp,varidfn
+	
+            varidyu1=NCVID(ncidp,'pyu1',rcode)
+            print*,'ncidp,varidyu1',ncidp,varidyu1
+	
+            varidyv1=NCVID(ncidp,'pyv1',rcode)
+            print*,'ncidp,varidyv1',ncidp,varidyv1
+	
+            varidfts1=NCVID(ncidp,'ftsol1',rcode)
+            print*,'ncidp,varidfts1',ncidp,varidfts1
+	
+            varidfts2=NCVID(ncidp,'ftsol2',rcode)
+            print*,'ncidp,varidfts2',ncidp,varidfts2
+         
+            varidfts3=NCVID(ncidp,'ftsol3',rcode)
+            print*,'ncidp,varidfts3',ncidp,varidfts3
+  
+            varidfts4=NCVID(ncidp,'ftsol4',rcode)
+            print*,'ncidp,varidfts4',ncidp,varidfts4
+	
+            varidpsr1=NCVID(ncidp,'psrf1',rcode)
+            print*,'ncidp,varidpsr1',ncidp,varidpsr1
+	
+            varidpsr2=NCVID(ncidp,'psrf2',rcode)
+            print*,'ncidp,varidpsr2',ncidp,varidpsr2
+	
+	    varidpsr3=NCVID(ncidp,'psrf3',rcode)
+            print*,'ncidp,varidpsr3',ncidp,varidpsr3
+
+            varidpsr4=NCVID(ncidp,'psrf4',rcode)
+            print*,'ncidp,varidpsr4',ncidp,varidpsr4
+	
+c ID pour les dimensions
+
+            status = nf_inq_dimid(ncidp,'y',yid)
+            status = nf_inq_dimid(ncidp,'x',xid)
+            status = nf_inq_dimid(ncidp,'sig_s',zid)
+            status = nf_inq_dimid(ncidp,'time_counter',tid)
+
+c lecture des dimensions
+
+            status = nf_inq_dim(ncidp,yid,namedim,ncjm)
+            status = nf_inq_dim(ncidp,xid,namedim,ncim)
+            status = nf_inq_dim(ncidp,zid,namedim,nckev)
+            status = nf_inq_dim(ncidp,tid,namedim,ncrec)
+	
+            zrec=ncrec
+            zkev=nckev
+            zim=ncim
+            zjm=ncjm
+	
+	    zkon=zim*(zjm-2)+2
+	
+	    write(*,*) 'read_pstoke : zrec = ', zrec
+            write(*,*) 'read_pstoke : kev = ', zkev
+            write(*,*) 'read_pstoke : zim = ', zim 
+            write(*,*) 'read_pstoke : zjm = ', zjm
+            write(*,*) 'read_pstoke : kon = ', zkon
+
+c niveaux de pression
+
+            status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
+
+c lecture de aire et phis
+	
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=0
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=1
+      count(4)=0
+
+c 
+c phis
+      status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
+
+c aire
+      status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
+      else
+
+      print*,'ok1'
+
+c ---------------------
+c   lecture des champs
+c ---------------------
+	
+	print*,'WARNING!!! Il n y a pas de test de coherence'
+        print*,'sur le nombre de niveaux verticaux dans le fichier nc'
+
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=irec
+
+      count(1)=zim
+      count(2)=zjm
+      count(3)=kev
+      count(4)=1
+
+c frac_impa 
+
+      status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
+
+c frac_nucl 
+
+      status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
+
+c abder t
+      status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
+
+c mfu
+      status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
+
+c mfd
+      status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
+
+c en_u 
+      status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
+
+c de_u 
+      status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
+
+c en_d 
+      status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
+
+c de_d 
+      status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
+      call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
+
+c coefh 
+	print*,'LECTURE de coefh a irec =',irec
+       status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
+       call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
+
+      start(3)=irec
+      start(4)=0
+      count(3)=1
+      count(4)=0
+
+c pyu1
+	print*,'LECTURE de yu1 a irec =',irec
+      status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
+
+c pyv1
+        print*,'LECTURE de yv1 a irec =',irec
+      status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
+
+c ftsol1
+        print*,'LECTURE de ftsol1 a irec =',irec
+      status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
+       call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
+
+c ftsol2
+        print*,'LECTURE de ftsol2 a irec =',irec
+      status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
+
+c ftsol3
+	 print*,'LECTURE de ftsol3 a irec =',irec
+      status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
+
+c ftsol4
+      status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
+
+c psrf1 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
+c      call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
+
+c psrf2 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
+c      call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
+
+c psrf3 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
+
+c psrf4 
+      status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
+      call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
+	
+          do i = 1,kon
+	
+	psrf(i,1) = psrf1(i)
+        psrf(i,2) = psrf2(i)
+        psrf(i,3) = psrf3(i)
+        psrf(i,4) = psrf4(i)
+  
+        ftsol(i,1) = ftsol1(i)
+        ftsol(i,2) = ftsol2(i)
+        ftsol(i,3) = ftsol3(i)
+        ftsol(i,4) = ftsol4(i)
+	
+          enddo
+	
+	endif
+	
+	return
+	
+	end
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/soil.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/soil.F	(revision 3)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/soil.F	(revision 300)
@@ -1,3 +1,3 @@
-      SUBROUTINE soil(ptimestep, indice, snow, ptsrf, ptsoil,
+      SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil,
      s          pcapcal, pfluxgrd)
       IMPLICIT NONE
@@ -47,4 +47,5 @@
 
 #include "dimensions.h"
+#include "YOMCST.h"
 #include "dimphy.h"
 #include "dimsoil.h"
@@ -56,5 +57,5 @@
 
       REAL ptimestep
-      INTEGER indice
+      INTEGER indice, knon
       REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
       REAL pcapcal(klon),pfluxgrd(klon)
@@ -65,5 +66,6 @@
 
       INTEGER ig,jk
-      REAL zdz2(nsoilmx),z1(klon)
+c$$$      REAL zdz2(nsoilmx),z1(klon)
+      REAL zdz2(nsoilmx),z1(klon,nbsrf)
       REAL min_period,dalph_soil
       REAL ztherm_i(klon)
@@ -72,13 +74,15 @@
 c   ----------------------
       REAL dz1(nsoilmx),dz2(nsoilmx)
-      REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+c$$$          REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+      REAL zc(klon,nsoilmx,nbsrf),zd(klon,nsoilmx,nbsrf)
       REAL lambda
       SAVE dz1,dz2,zc,zd,lambda
-      LOGICAL firstcall
-      SAVE firstcall
+      LOGICAL firstcall, firstsurf(nbsrf)
+      SAVE firstcall, firstsurf
       REAL isol,isno,iice
       SAVE isol,isno,iice
 
       DATA firstcall/.true./
+      DATA firstsurf/.TRUE.,.TRUE.,.TRUE.,.TRUE./
 
       DATA isol,isno,iice/2000.,2000.,2000./
@@ -90,5 +94,5 @@
       REAL fz,rk,fz1,rk1,rk2
       fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
-
+      pfluxgrd(:) = 0.
 c   calcul de l'inertie thermique a partir de la variable rnat.
 c   on initialise a iice meme au-dessus d'un point de mer au cas 
@@ -97,20 +101,20 @@
 c
       IF (indice.EQ.is_sic) THEN
-         DO ig = 1, klon
+         DO ig = 1, knon
             ztherm_i(ig)   = iice
             IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
          ENDDO
       ELSE IF (indice.EQ.is_lic) THEN
-         DO ig = 1, klon
+         DO ig = 1, knon
             ztherm_i(ig)   = iice
             IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
          ENDDO
       ELSE IF (indice.EQ.is_ter) THEN
-         DO ig = 1, klon
+         DO ig = 1, knon
             ztherm_i(ig)   = isol
             IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
          ENDDO
       ELSE IF (indice.EQ.is_oce) THEN
-         DO ig = 1, klon
+         DO ig = 1, knon
             ztherm_i(ig)   = iice
          ENDDO
@@ -121,5 +125,6 @@
 
 
-      IF (firstcall) THEN
+c$$$      IF (firstcall) THEN
+      IF (firstsurf(indice)) THEN 
 
 c-----------------------------------------------------------------------
@@ -162,6 +167,7 @@
      .               fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
          ENDDO
-
-         firstcall =.false.
+C PB
+         firstsurf(indice) = .FALSE. 
+c$$$         firstcall =.false.
 
 c   Initialisations:
@@ -175,13 +181,14 @@
 
 c    surface temperature
-         DO ig=1,klon
-            ptsoil(ig,1)=(lambda*zc(ig,1)+ptsrf(ig))/
-     s      (lambda*(1.-zd(ig,1))+1.)
+         DO ig=1,knon
+            ptsoil(ig,1)=(lambda*zc(ig,1,indice)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1,indice))+1.)
          ENDDO
 
 c   other temperatures
          DO jk=1,nsoilmx-1
-            DO ig=1,klon
-               ptsoil(ig,jk+1)=zc(ig,jk)+zd(ig,jk)*ptsoil(ig,jk)
+            DO ig=1,knon
+               ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice)
+     $            *ptsoil(ig,jk)
             ENDDO
          ENDDO
@@ -192,20 +199,30 @@
 c   ---------------------------------------------------------------
 
+c$$$  PB ajout pour cas glace de mer
+      IF (indice .EQ. is_sic) THEN
+          DO ig = 1 , knon
+            ptsoil(ig,nsoilmx) = RTT - 1.8
+          END DO 
+      ENDIF 
+
       DO jk=1,nsoilmx
          zdz2(jk)=dz2(jk)/ptimestep
       ENDDO
 
-      DO ig=1,klon
-         z1(ig)=zdz2(nsoilmx)+dz1(nsoilmx-1)
-         zc(ig,nsoilmx-1)=zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig)
-         zd(ig,nsoilmx-1)=dz1(nsoilmx-1)/z1(ig)
+      DO ig=1,knon
+         z1(ig,indice)=zdz2(nsoilmx)+dz1(nsoilmx-1)
+         zc(ig,nsoilmx-1,indice)=
+     $       zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig,indice)
+         zd(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1(ig,indice)
       ENDDO
 
       DO jk=nsoilmx-1,2,-1
-         DO ig=1,klon
-            z1(ig)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)*(1.-zd(ig,jk)))
-            zc(ig,jk-1)=
-     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk))*z1(ig)
-            zd(ig,jk-1)=dz1(jk-1)*z1(ig)
+         DO ig=1,knon
+            z1(ig,indice)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)
+     $         *(1.-zd(ig,jk,indice)))
+            zc(ig,jk-1,indice)=
+     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk,indice))
+     $          *z1(ig,indice)
+            zd(ig,jk-1,indice)=dz1(jk-1)*z1(ig,indice)
          ENDDO
       ENDDO
@@ -216,13 +233,15 @@
 c   ---------------------------------
 
-      DO ig=1,klon
+      DO ig=1,knon
          pfluxgrd(ig)=ztherm_i(ig)*dz1(1)*
-     s   (zc(ig,1)+(zd(ig,1)-1.)*ptsoil(ig,1))
+     s   (zc(ig,1,indice)+(zd(ig,1,indice)-1.)*ptsoil(ig,1))
          pcapcal(ig)=ztherm_i(ig)*
-     s   (dz2(1)+ptimestep*(1.-zd(ig,1))*dz1(1))
-         z1(ig)=lambda*(1.-zd(ig,1))+1.
-         pcapcal(ig)=pcapcal(ig)/z1(ig)
-         pfluxgrd(ig)=pfluxgrd(ig)
-     s   +pcapcal(ig)*(ptsoil(ig,1)*z1(ig)-lambda*zc(ig,1)-ptsrf(ig))
+     s   (dz2(1)+ptimestep*(1.-zd(ig,1,indice))*dz1(1))
+         z1(ig,indice)=lambda*(1.-zd(ig,1,indice))+1.
+         pcapcal(ig)=pcapcal(ig)/z1(ig,indice)
+         pfluxgrd(ig) = pfluxgrd(ig)
+     s   + pcapcal(ig) * (ptsoil(ig,1) * z1(ig,indice)
+     $       - lambda * zc(ig,1,indice)
+     $       - ptsrf(ig))
      s   /ptimestep
       ENDDO
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/tilft43.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/tilft43.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/tilft43.F	(revision 300)
@@ -0,0 +1,93 @@
+c $Header$
+        SUBROUTINE TLIFT43(P,T,Q,QS,GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
+        REAL GZ(ND),TPK(ND),CLW(ND),P(ND)
+        REAL T(ND),Q(ND),QS(ND),TVP(ND),LV0
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c -- sb:
+c!      CPD=1005.7
+c!      CPV=1870.0
+c!      CL=4190.0
+c!      RV=461.5
+c!      RD=287.04
+c!      LV0=2.501E6
+c!      G=9.8
+c!      ROWL=1000.0
+c ajouts:
+#include "YOMCST.h"
+        CPD = RCPD
+        CPV = RCPV
+        CL = RCW
+        LV0 = RLVTT
+        G = RG
+        ROWL= RATM/100.
+        GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+C sb --
+C
+        CPVMCL=CL-CPV
+        EPS=RD/RV
+        EPSI=1./EPS
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        AH0=(CPD*(1.-Q(NK))+CL*Q(NK))*T(NK)+Q(NK)*(LV0-CPVMCL*(
+     1   T(NK)-273.15))+GZ(NK)
+        CPP=CPD*(1.-Q(NK))+Q(NK)*CPV
+        CPINV=1./CPP
+C
+        IF(KK.EQ.1)THEN
+C
+C   ***   CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE   ***
+C
+        DO 50 I=1,ICB-1
+         CLW(I)=0.0
+   50   CONTINUE
+        DO 100 I=NK,ICB-1
+         TPK(I)=T(NK)-(GZ(I)-GZ(NK))*CPINV
+         TVP(I)=TPK(I)*(1.+Q(NK)*EPSI)
+  100   CONTINUE
+        END IF
+C
+C    ***  FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE    ***
+C
+        NST=ICB
+        NSB=ICB
+        IF(KK.EQ.2)THEN  
+         NST=NL
+         NSB=ICB+1
+        END IF
+        DO 300 I=NSB,NST
+         TG=T(I)
+         QG=QS(I)
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         DO 200 J=1,2
+          S=CPD+ALV*ALV*QG/(RV*T(I)*T(I))
+          S=1./S
+          AHG=CPD*TG+(CL-CPD)*Q(NK)*T(I)+ALV*QG+GZ(I)
+          TG=TG+S*(AH0-AHG)
+          TG=MAX(TG,35.0)
+          TC=TG-273.15
+          DENOM=243.5+TC
+          IF(TC.GE.0.0)THEN  
+           ES=6.112*EXP(17.67*TC/DENOM)
+          ELSE  
+           ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
+          END IF  
+          QG=EPS*ES/(P(I)-ES*(1.-EPS))
+  200    CONTINUE
+         ALV=LV0-CPVMCL*(T(I)-273.15)
+         TPK(I)=(AH0-(CL-CPD)*Q(NK)*T(I)-GZ(I)-ALV*QG)/CPD
+         CLW(I)=Q(NK)-QG
+         CLW(I)=MAX(0.0,CLW(I))
+         RG=QG/(1.-Q(NK))
+         TVP(I)=TPK(I)*(1.+RG*EPSI)
+  300   CONTINUE
+
+c -- sb:
+        RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+c sb --
+
+        RETURN
+        END
+
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/tlift.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/tlift.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/tlift.F	(revision 300)
@@ -0,0 +1,243 @@
+c $Header$
+        SUBROUTINE TLIFT(P,T,RR,RS,GZ,PLCL,ICB,NK,
+     .                  TVP,TPK,CLW,ND,NL,
+     .                  DTVPDT1,DTVPDQ1)
+C
+C     Argument NK ajoute (jyg) = Niveau de depart de la
+C     convection
+C
+        PARAMETER (NA=60)
+        REAL GZ(ND),TPK(ND),CLW(ND)
+        REAL T(ND),RR(ND),RS(ND),TVP(ND),P(ND)
+        REAL DTVPDT1(ND),DTVPDQ1(ND)   ! Derivatives of parcel virtual
+C                                   temperature wrt T1 and Q1
+C
+        REAL CLW_NEW(NA),QI(NA)
+        REAL DTPDT1(NA),DTPDQ1(NA)      ! Derivatives of parcel temperature
+C                                   wrt T1 and Q1
+ 
+C
+        LOGICAL ICE_CONV
+C
+C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
+C
+c sb        CPD=1005.7
+c sb      CPV=1870.0
+c sb        CL=4190.0
+c sb        CPVMCL=2320.0
+c sb        RV=461.5
+c sb        RD=287.04
+c sb        EPS=RD/RV
+c sb        ALV0=2.501E6
+ccccccccccccccccccccccc
+c constantes coherentes avec le modele du Centre Europeen
+c sb      RD = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 28.9644
+c sb      RV = 1000.0 * 1.380658E-23 * 6.0221367E+23 / 18.0153
+c sb      CPD = 3.5 * RD
+c sb      CPV = 4.0 * RV
+c sb      CL = 4218.0
+c sb      CI=2090.0
+c sb      CPVMCL=CL-CPV
+c sb      CLMCI=CL-CI
+c sb      EPS=RD/RV
+c sb      ALV0=2.5008E+06
+c sb      ALF0=3.34E+05
+ 
+cccccccccccc
+c on utilise les constantes thermo du Centre Europeen: (SB)
+c
+#include "YOMCST.h"
+       GRAVITY = RG !sb: Pr que gravite ne devienne pas humidite!
+c
+       CPD = RCPD
+       CPV = RCPV
+       CL = RCW
+       CI = RCS
+       CPVMCL = CL-CPV
+       CLMCI = CL-CI
+       EPS = RD/RV
+       ALV0 = RLVTT
+       ALF0 = RLMLT ! (ALF0 = RLSTT-RLVTT)
+c 
+cccccccccccccccccccccc
+C
+C   ***  CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY   ***
+C
+        ICB1=MAX(ICB,2)
+        ICB1=MIN(ICB,NL)
+C
+Cjyg1
+CC      CPP=CPD*(1.-RR(1))+RR(1)*CPV
+      CPP=CPD*(1.-RR(NK))+RR(NK)*CPV
+Cjyg2
+      CPINV=1./CPP
+Cjyg1
+C         ICB may be below condensation level
+CCC        DO 100 I=1,ICB1-1
+CCC         TPK(I)=T(1)-GZ(I)*CPINV
+CCC         TVP(I)=TPK(I)*(1.+RR(1)/EPS)
+        DO 50 I=1,ICB1
+         CLW(I)=0.0
+50      CONTINUE
+C
+        DO 100 I=NK,ICB1
+         TPK(I)=T(NK)-(GZ(I) - GZ(NK))*CPINV
+Cjyg1
+CCC         TVP(I)=TPK(I)*(1.+RR(NK)/EPS)
+         TVP(I)=TPK(I)*(1.+RR(NK)/EPS-RR(NK))
+Cjyg2
+         DTVPDT1(I) = 1.+RR(NK)/EPS-RR(NK)
+         DTVPDQ1(I) = TPK(I)*(1./EPS-1.)
+C
+Cjyg2
+ 
+  100   CONTINUE
+ 
+C
+C    ***  FIND LIFTED PARCEL TEMPERATURE AND MIXING RATIO    ***
+C
+Cjyg1
+CC        AH0=(CPD*(1.-RR(1))+CL*RR(1))*T(1)
+CC     $     +RR(1)*(ALV0-CPVMCL*(T(1)-273.15))
+        AH0=(CPD*(1.-RR(NK))+CL*RR(NK))*T(NK)
+     $     +RR(NK)*(ALV0-CPVMCL*(T(NK)-273.15)) + GZ(NK)
+Cjyg2
+C
+Cjyg1
+        IMIN = ICB1
+C         If ICB is below LCL, start loop at ICB+1
+        IF (PLCL .LT. P(ICB1)) IMIN = MIN(IMIN+1,NL)
+C
+CCC        DO 300 I=ICB1,NL
+        DO 300 I=IMIN,NL
+Cjyg2
+         ALV=ALV0-CPVMCL*(T(I)-273.15)
+         ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        RG=RS(I)
+        TG=T(I)
+C       S=CPD+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg1
+CC        S=CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*RG/(RV*T(I)*T(I))
+        S=CPD*(1.-RR(NK))+CL*RR(NK)+ALV*ALV*RG/(RV*T(I)*T(I))
+Cjyg2
+        S=1./S
+ 
+        DO 200 J=1,2
+Cjyg1
+CC         AHG=CPD*TG+(CL-CPD)*RR(1)*TG+ALV*RG+GZ(I)
+         AHG=CPD*TG+(CL-CPD)*RR(NK)*TG+ALV*RG+GZ(I)
+Cjyg2
+        TG=TG+S*(AH0-AHG)
+        TC=TG-273.15
+        DENOM=243.5+TC
+        DENOM=MAX(DENOM,1.0)
+C
+C       FORMULE DE BOLTON POUR PSAT
+C
+        ES=6.112*EXP(17.67*TC/DENOM)
+        RG=EPS*ES/(P(I)-ES*(1.-EPS))
+ 
+ 
+  200   CONTINUE
+ 
+Cjyg1
+CC        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(1))
+        TPK(I)=(AH0-GZ(I)-ALV*RG)/(CPD+(CL-CPD)*RR(NK))
+Cjyg2
+C       TPK(I)=(AH0-GZ(I)-ALV*RG-(CL-CPD)*T(I)*RR(1))/CPD
+ 
+Cjyg1
+CC        CLW(I)=RR(1)-RG
+        CLW(I)=RR(NK)-RG
+Cjyg2
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+RG/EPS)
+        TVP(I)=TPK(I)*(1.+RG/EPS-RR(NK))
+Cjyg2
+C
+Cjyg1       Derivatives
+C
+        DTPDT1(I) = CPD*S
+        DTPDQ1(I) = ALV*S
+C
+         DTVPDT1(I) = DTPDT1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) )
+        DTVPDQ1(I) = DTPDQ1(I)*(1. + RG/EPS -
+     .           RR(NK) + ALV*RG/(RD*TPK(I)) ) - TPK(I)
+C
+Cjyg2
+ 
+  300   CONTINUE
+C
+      ICE_CONV = .FALSE.
+
+      IF (ICE_CONV) THEN
+C
+CJAM
+C       RAJOUT DE LA PROCEDURE ICEFRAC
+C
+c sb        CALL ICEFRAC(T,CLW,CLW_NEW,QI,ND,NL)
+ 
+        DO 400 I=ICB1,NL
+        IF (T(I).LT.263.15) THEN
+        TG=TPK(I)
+        TC=TPK(I)-273.15
+        DENOM=243.5+TC
+        ES=6.112*EXP(17.67*TC/DENOM)
+        ALV=ALV0-CPVMCL*(T(I)-273.15)
+        ALF=ALF0+CLMCI*(T(I)-273.15)
+ 
+        DO J=1,4
+        ESI=EXP(23.33086-(6111.72784/TPK(I))+0.15215*LOG(TPK(I)))
+        QSAT_NEW=EPS*ESI/(P(I)-ESI*(1.-EPS))
+CCC        SNEW= CPD*(1.-RR(1))+CL*RR(1)+ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+        SNEW= CPD*(1.-RR(NK))+CL*RR(NK)
+     .        +ALV*ALV*QSAT_NEW/(RV*TPK(I)*TPK(I))
+C
+        SNEW=1./SNEW
+        TPK(I)=TG+(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+c$$$        PRINT*,'################################'
+c$$$        PRINT*,TPK(I)
+c$$$        PRINT*,(ALF*QI(I)+ALV*RG*(1.-(ESI/ES)))*SNEW
+        ENDDO
+CCC        CLW(I)=RR(1)-QSAT_NEW
+        CLW(I)=RR(NK)-QSAT_NEW
+        CLW(I)=MAX(0.0,CLW(I))
+Cjyg1
+CCC        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS)
+        TVP(I)=TPK(I)*(1.+QSAT_NEW/EPS-RR(NK))
+Cjyg2
+        ELSE
+        CONTINUE
+        ENDIF
+ 
+  400   CONTINUE
+C
+      ENDIF
+C
+ 
+******************************************************
+** BK :  RAJOUT DE LA TEMPERATURE DES ASCENDANCES
+**   NON DILUES AU  NIVEAU KLEV = ND
+**   POSONS LE ENVIRON EGAL A CELUI DE KLEV-1
+********************************************************
+ 
+      TPK(NL+1)=TPK(NL)
+ 
+*******************************************************
+
+      RG = GRAVITY  ! RG redevient la gravite de YOMCST (sb)
+ 
+ 
+        RETURN
+        END
+ 
+ 
+ 
+ 
+ 
+ 
+ 
+ 
Index: LMDZ.3.3/tags/CCM1_0/libf/phylmd/zilch.F
===================================================================
--- LMDZ.3.3/tags/CCM1_0/libf/phylmd/zilch.F	(revision 300)
+++ LMDZ.3.3/tags/CCM1_0/libf/phylmd/zilch.F	(revision 300)
@@ -0,0 +1,13 @@
+      subroutine zilch(x,m)
+c
+c Zero the real array x dimensioned m.
+c
+      implicit none
+c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
