Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/README
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/README	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/README	(revision 428)
@@ -0,0 +1,78 @@
+13/04
+Installation de LMDZ.3.3 sur Etoile avec M-A Foujols
+Installation de ioipsl sur Etoile (M-A Foujols)
+Modification de create_gcm, makegcm en consequence
+Pour tenir compte de la taille des fichiers *.o et
+des librairies en F90 on compile seulement les routines
+utilisant ioipsl en F90, le reste en F77. <- en cours
+
+Creation d'un directory phylmd.old (sans traceurs)
+dans phylmd suppression des *new.F pour eviter erreurs. <- en cours
+modif dans dyn3d pour compatibilite 2 phylmd. <- OK
+
+14/04
+Dans phylmd.old mise a jour physiq.F / ioipsl F90
+dans phylmd suppression des *new.F <- OK
+Dans clmain il faut supprimer cltrac car appels differents
+dans phylmd et plylmd.old
+
+Modification de makegcm et create_make_gcm (M-A Foujols)
+pour tenir compte de la compil F90 de ioipsl. <-OK
+
+15/04
+Creation dans RUN de job_init et job_gcm pour lancer en batch
+les creations de fichiers et le modele.
+
+16/04
+correction de cltracrn.F (rajout d'une variable d'appel).
+correction de makegcm / option debug
+
+19/04
+correction de clafis.F initialisation de dq.
+appel de fluxstoke.F dans gcm.F
+
+20/04
+suppression de idadvtrac
+rajout de iapp_phy et iapp_dyn les pdt de sorties dans la dyn et la phy.
+
+21/04
+correction de fluxstoke.F rajout save phic,tetac
+correction fisrtilp_tr.F manque init de zoliq si rneb=0
+
+22/04
+iapp_dyn rempalce par istdyn et iapp_phy par istphy
+
+23/04
+Correction dans physiq dans sorties ioipsl = supression de d_q_ajs
+qui n'est plus def a ce niveau.
+corrections alex dans clmain, fisrtilpr_tr, physiq
+
+26/04
+correction  cltracrn / def de hsoltr, tautr, vdept, scavtr, masktr, fshtr
+?? a quoi set lessi* dans phytrac
+phytrac rajout du calcul de trs  (+SAVE)
+
+rajout de assign pour option CRAY pour ecriture de fluxmass et physique.
+
+Ioipsl dans la partie traceurs (histrac.nc) => phytrac en F90
+
+27/04
+plante quand option convection activee = dans nflxtr
+zmfxd mal def
+dx calcule seulement pour klev
+
+03/05
+correction de nflxtr
+zmfdx et dx
+
+A FAIRE
+Verifier que run on-line off-line donne meme resultat / traceurs
+
+Verifier que run sans traceurs donne meme resultat meteo / traceurs
+
+Phaser / ioispl de L. Fairhead.
+
+Ioipsl dans la partie traceurs quand OK pour entrees-sorties 
+- dans phylmd = phystoke (Kz et flux convect)
+- dans dyn3d = fluxstoke (flux masse, cumul)
+(garder poss. anciennes sorties.)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/create_make_gcm
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/create_make_gcm	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/create_make_gcm	(revision 428)
@@ -0,0 +1,227 @@
+#!/bin/sh
+#set -xv
+machine=`hostname`
+os=`uname`
+gcm=`pwd`
+libf=$gcm/libf
+libo=$gcm/libo
+CRAY=0
+if [ "$machine" = "atlas" -o "$machine" = "etoile" -o "$machine" = "axis" ] ; then
+  CRAY=1
+fi
+XNEC=0
+if [ "$machine" = "rhodes" ] ; then
+  XNEC=1
+fi
+VPP=0
+if [ "$machine" = "nymphea0" ] ; then
+  VPP=1
+fi
+#
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Definitions de Macros pour Make"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo "# Repertoires :"
+echo
+echo "GCM     = "$gcm
+if [ "$CRAY" = '0' ] ; then
+   echo "MACHINE = sun4"
+fi
+echo 'LIBF    = $(GCM)/libf'
+if [ "$CRAY" = '0' ] ; then
+#   echo 'LIBO    = $(GCM)/libo/$(MACHINE)'
+   echo 'LIBO    = $(LIBOGCM)/$(MACHINE)'
+else
+   echo 'LIBO    = $(GCM)/libo'
+fi
+#echo 'LOCAL_DIR=$(GCM)'
+#echo $localdir
+echo "LOCAL_DIR=`echo $localdir`"
+echo 'BIBIO    = $(LIBF)/bibio'
+echo "FILTRE   = filtre"
+echo "PHYS  = "
+echo "DYN  = dyn "
+echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a'
+echo 'DIRMAIN=dyn$(DIM)d'
+echo 'RM=rm'
+echo
+echo "OPLINK = "
+echo
+echo '# Les differentes librairies pour l"edition des liens:'
+echo
+if [ "$XNEC" = '1' ] ; then
+  echo 'dyn3d      = $(LIBO)/libsxdyn3d.a $(LIBO)/libsx$(FILTRE).a'
+  echo 'dyn2d      = $(LIBO)/libsxdyn2d.a'
+  echo 'dyn1d      = $(LIBO)/libsxdyn1d.a'
+  echo 'L_DYN      = -lsxdyn$(DIM)d'
+  echo 'L_FILTRE   = -lsx$(FILTRE)'
+  echo 'L_PHY = -lsxphy$(PHYS) '
+  echo 'L_BIBIO    = -lsxbibio'
+  echo 'L_ADJNT    ='
+else
+  echo 'dyn3d      = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a'
+  echo 'dyn2d      = $(LIBO)/libdyn2d.a'
+  echo 'dyn1d      = $(LIBO)/libdyn1d.a'
+  echo 'L_DYN      = -ldyn$(DIM)d'
+  echo 'L_FILTRE   = -l$(FILTRE)'
+  echo 'L_PHY = -lphy$(PHYS) '
+  echo 'L_BIBIO    = -lbibio'
+  echo 'L_ADJNT    ='
+fi
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Option de compilation FORTRAN"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+   echo 'COMPILE = $(F77) $(OPTIM) $(INCLUDE) -c'
+   echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c'
+   echo 'COMPTRU90 = $(F90) $(OPTIMTRU90) $(INCLUDE) -c'
+   echo "LINK    = $LINK"
+   echo "AR      = $AR"
+echo
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Creation des differents executables"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo "# Executables:"
+echo "# ------------"
+echo
+echo "PROG = code"
+echo
+echo 'main : $(DYN) bibio phys $(OPTION_DEP) '
+echo '	cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\'
+echo '	cd $(LOCAL_DIR); \'
+echo '	$(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
+if [ "$CRAY" = '0' ] ; then
+echo '	$(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_PHY) $(L_BIBIO) $(L_DYN) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
+else
+echo '	$(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_PHY) $(L_BIBIO) $(OPLINK) $(OPTION_LINK) -o $(LOCAL_DIR)/$(PROG).e ; $(RM) $(PROG).o '
+fi
+echo
+echo 'dyn : $(LIBO)/libdyn$(DIM)d.a $(FILTRE)$(DIM)d'
+echo
+echo 'phys : $(LIBPHY)'
+echo
+echo 'bibio : $(LIBO)/libbibio.a'
+echo
+echo 'adjnt : $(LIBO)/libadjnt.a'
+echo
+echo '$(FILTRE)3d : $(LIBO)/lib$(FILTRE).a'
+echo
+echo '$(FILTRE)2d :'
+echo
+echo '$(FILTRE)1d :'
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Contenu des differentes bibliotheques"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo
+cd $libf >/dev/null 2>&1
+for diri in ` ls `
+do
+   if [ -d $diri ] ; then
+   if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.F90`" != "" ]  ; then 
+      cd $diri >/dev/null 2>&1
+      echo
+      listlib=""
+      for i in `ls *.F`
+      do
+         fili=`basename $i .F`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then 
+            listlib=$listlib" "$fili
+         fi
+      done
+      for i in `ls *.F90`
+      do
+         fili=`basename $i .F90`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then
+            listlib=$listlib" "$fili
+         fi 
+      done
+#
+      echo
+      echo
+      echo "#======================================================================="
+      echo "# Contenu de la bibliotheque correspondant au Directory "$diri
+      echo "#======================================================================="
+      echo
+      for fili in $listlib
+      do
+         echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)"
+         echo
+      done
+      echo '.PRECIOUS	: $(LIBO)/lib'$diri'.a'
+      echo
+      echo
+      echo "# Compilation des membres de la bibliotheque lib"$diri".a"
+      echo
+      for fili in $listlib
+      do
+         if [ -f $fili.F90 ] ; then
+           trufile=$fili.F90
+         else
+           trufile=$fili.F
+         fi
+         F90=0 ; egrep -i '^ *use ' $trufile > /dev/null 2>&1 && F90=1
+                 egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1
+         str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$trufile
+         [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F
+         for stri in ` ( sed -n "/\#include/s/\#include//p" $trufile | sed 's/\"//g' ; egrep -i '^ *use ' $trufile | awk ' { print $2 } ' ) `
+         do
+            stri=`echo $stri | tr [A-Z] [a-z]`
+            if [ -f $stri ] ; then
+               echo $str1 \\
+               str1='$(LIBF)/'$diri'/'$stri
+            else
+               if [ -f $stri.F ] || [ -f $stri.F90 ] ; then
+                  echo $str1 \\
+                  str1='$(LIBO)/lib'$diri'.a('$stri'.o)'
+               else
+                  for dirinc in dyn3d grid bibio
+                  do
+                     if [ -f ../$dirinc/$stri ] ; then
+                        echo $str1 \\
+                        str1='$(LIBF)/'`cd .. ; ls */$stri | head -1`
+                     fi
+                  done
+               fi
+            fi
+         done
+         echo $str1
+	 if [ "$F90" -eq '0' ] ; then
+           echo '	cd $(LOCAL_DIR); \'
+	   echo '	$(COMPILE) $(LIBF)/'$diri'/'$trufile' ; \'
+	 else
+           echo '	cd $(LOCAL_DIR); \'
+           if [ -f $fili.F90 ] ; then
+	      echo '	$(COMPTRU90) $(LIBF)/'$diri'/'$trufile' ; \'
+           else
+	      echo '	$(COMPILE90) $(LIBF)/'$diri'/'$trufile' ; \'
+           fi
+           MODU=0; egrep -i ' *module ' $trufile> /dev/null 2>&1 && MODU=1
+            if [ "$MODU" -eq '1' -a "$CRAY" != '1' ] ; then
+              if [ "$os" = 'UNIX_System_V' ] ; then
+                echo '	cp $(MOD_LOC_DIR)/*.$(MOD_SUFFIX) $(LIBO)/ ; \'
+              else
+                echo '	mv $(MOD_LOC_DIR)/'$fili'.$(MOD_SUFFIX) $(LIBO)/'$fili'.$(MOD_SUFFIX) ; \'
+              fi
+            fi
+	 fi
+         if [ "$XNEC" -eq '1' ] ; then
+           echo '	sxar r $(LIBO)/libsx'$diri'.a '$fili'.o ; \'
+         fi
+         echo '	$(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \'
+         echo '	cd $(GCM)'
+	 echo
+      done
+#	 
+      echo
+   cd $libf
+   fi
+   fi
+done
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/gcm.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/gcm.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/gcm.def	(revision 428)
@@ -0,0 +1,67 @@
+## $Header$
+## nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+day_step=480
+## periode pour le pas Matsuno (en pas)
+iperiod=5
+## periode de la dissipation (en pas)
+idissip=5
+## choix de l'operateur de dissipation (star ou  non star )
+lstardis=y
+## 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=10800.
+## temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+tetagrot=10800.
+## temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+tetatemp=10800.
+## coefficient pour gamdissip                                            
+coefdis=0.
+## choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) 
+purmats=n
+## avec ou sans physique                                                 
+physic=y
+## periode de la physique (en pas)                                       
+iphysiq=10
+## frequence (en  jours ) de l'ecriture du fichier histphy               
+ecritphy=30
+##  Cycle diurne  ou non                 
+cycle_diurne=y
+##  Soil Model  ou non               
+soil_model=y
+##  Choix ou non  de  New oliq               
+new_oliq=y
+##  Orodr  ou  non   pour l orographie              
+ok_orodr=y
+##  Orolf  ou  non   pour l orographie              
+ok_orolf=y
+##   Si = .T. ,  lecture du fichier limit avec la bonne annee             
+ok_limitvrai=n
+## Nombre  d'appels des routines de rayonnements ( par jour)                 
+nbapp_rad=12
+##  Flag  pour la convection (1 pour LMD, 2 pour Tiedtke, 3 KE, 4 KE vect)
+iflag_con=3
+## longitude en degres du centre du zoom                                 
+clon=0.
+## latitude en degres du centre du zoom                                  
+clat=0.
+## facteur de grossissement du zoom,selon longitude                      
+grossismx=1.0
+## facteur de grossissement du zoom ,selon latitude                      
+grossismy=1.0
+##  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+fxyhypb=y
+## extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+dzoomx=0.0
+## extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+dzoomy=0.0
+##raideur du zoom en  X
+taux=3.
+##raideur du zoom en  Y
+tauy=3.
+##  Fonction  f(y) avec y = Sin(latit.) si = .true. , sinon y = latit.         
+ysinus=y
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/initialisation
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/initialisation	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/initialisation	(revision 428)
@@ -0,0 +1,52 @@
+#!/bin/csh -vx
+
+# en local
+
+set dir=~lmdz/DATA/Netcdf
+set cp="ln -s"
+setenv LIBOGCM /tmp2/fairhead
+
+#===================================================================
+# Fichiers necessaires a la creations des etats initiaux
+#===================================================================
+$cp $dir/ECDYN.nc .                         # Etat initial dynamique
+$cp $dir/ECPHY.nc .                         # Etat initial physique
+$cp $dir/Relief.nc .                        # Fichier de relief
+$cp $dir/Rugos.nc .                         # Fichier rugosite sur un an
+$cp $dir/AMIP.nc .                          # Fichier SST/Seaice sur un an
+$cp $dir/Albedo.nc .                        # Fichier albedo sur un an
+#===================================================================
+
+
+if ( ! -f run.def ) then
+echo Il faut avoir sur le repertoire courant un fichier run.def
+exit
+endif
+
+# Compilation etat0_netcdf.e
+# ==========================
+$LMDGCM/makegcm etat0
+
+# Creation des etats initiaux
+# ===========================
+echo "execution de etat0.e, sortie dans etat0.l"
+./etat0.e >! etat0.l
+
+# Compilation limit_netcdf.e
+# ==========================
+$LMDGCM/makegcm limit_netcdf
+
+# Creation des conditions aux limites
+# ===================================
+echo "execution de limit_lmd.e, sortie dans limit_lmd.l"
+./limit_netcdf.e >! limit_netcdf.l
+
+# Conditions aux limites pour les especes traces
+# ==============================================
+#if ( -f limit_tr.e ) then
+#$cp $dir/so2_1x1 so2_1x1
+#limit_tr.e > limit_tr.l
+#else
+#echo Vous n avez pas cree le fichier limit_tr utilise par les versions
+#echo du modele avec traceurs
+#endif
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/formcoord.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/formcoord.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/formcoord.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/bibio/initdynav.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/initdynav.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/initdynav.F	(revision 428)
@@ -0,0 +1,177 @@
+c
+c $Header$
+c
+      subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt
+     .                     ,nq,fileid)
+
+       USE IOIPSL
+       USE histcom
+
+      implicit none
+
+C
+C   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+C   au format IOIPSL. Initialisation du fichier histoire moyenne.
+C
+C   Appels succesifs des routines: histbeg
+C                                  histhori
+C                                  histver
+C                                  histdef
+C                                  histend
+C
+C   Entree:
+C
+C      infile: nom du fichier histoire a creer
+C      day0,anne0: date de reference
+C      tstep : frequence d'ecriture
+C      t_ops: frequence de l'operation pour IOIPSL
+C      t_wrt: frequence d'ecriture sur le fichier
+C      nq: nombre de traceurs
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+
+C   Arguments
+C
+      character*(*) infile
+      integer*4 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid
+      integer nq
+      integer thoriid, zvertiid
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer ii,jj
+      integer zan, dayref
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = anne0
+      dayref = day0
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj)  = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+       
+      call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sigss', 'Niveaux sigma','Pa',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      write(6,*)'inithistave',tstep
+      call histdef(fileid, 'u', 'vents u scalaires moyennes',
+     .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Vents V
+C
+      call histdef(fileid, 'v', 'vents v scalaires moyennes',
+     .             'm/s', iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+C
+C  Temperature
+C
+      call histdef(fileid, 'temp', 'temperature moyennee', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'theta', 'temperature potentielle', 'K',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+
+
+C
+C  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel moyenne', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+      IF(nq.GE.1) THEN
+        DO iq=1,nq
+          IF ( iq.LE.9 ) THEN
+            WRITE(str(2:2),'(i1.1)') iq
+            write(ctrac(9:9),'(i1.1)') iq
+          ELSE
+            WRITE(str(2:3),'(i2.2)') iq
+            write(ctrac(9:10),'(i2.2)') iq
+          ENDIF
+          call histdef(fileid, str, ctrac, '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', t_ops, t_wrt)
+        enddo
+      endif
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'ave(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/initfluxsto.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/initfluxsto.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/initfluxsto.F	(revision 428)
@@ -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, idayref
+      logical ok_sync
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+      ok_sync = .true.
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = annee_ref
+      idayref = day_ref
+      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+      tau0 = itau_dyn
+	
+	do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+ 
+      call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, uhoriid, fileid)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg('fluxstokev.nc', iip1, rlong(:,1), jjm, rlat(1,:),
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+	
+	rl(1,1) = 1.	
+      call histbeg('defstoke.nc', 1, rl, 1, rl,
+     .             1, 1, 1, 1,
+     .             tau0, zjulian, tstep, dhoriid, filedid)
+
+C
+C  Appel a histhori pour rajouter les autres grilles horizontales
+C
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histhori(fileid, iip1, rlong, jjp1, rlat, 'scalar',
+     .              'Grille points scalaires', thoriid)
+	
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'sig_s', 'Niveaux sigma',
+     . 'sigma_level',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              llm, nivsigs, zvertiid)
+c pour le fichier def
+      nivd(1) = 1
+      call histvert(filedid, 'sig_s', 'Niveaux sigma',
+     .  'sigma_level',
+     .              1, nivd, dvertiid)
+
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+	
+	CALL histdef(fileid, "phis", "Surface geop. height", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+         CALL histdef(fileid, "aire", "Grid area", "-",
+     .                iip1,jjp1,thoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+	
+	CALL histdef(filedid, "dtvr", "tps dyn", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+        
+         CALL histdef(filedid, "istdyn", "tps stock", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+         
+         CALL histdef(filedid, "istphy", "tps stock phy", "s",
+     .                1,1,dhoriid, 1,1,1, -99, 32,
+     .                "once", t_ops, t_wrt)
+
+
+C
+C Masse 
+C
+      call histdef(fileid, 'masse', 'Masse', 'kg',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pbaru 
+C
+      call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Pbarv 
+C
+      call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s',
+     .             iip1, jjm, vhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  w 
+C
+      call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+
+C
+C  Temperature potentielle
+C
+      call histdef(fileid, 'teta', 'temperature potentielle', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+
+C
+C Geopotentiel 
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      call histend(filedid)
+      if (ok_sync) then
+        call histsync(fileid)
+        call histsync(filevid)
+        call histsync(filedid)
+      endif
+	
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/inithist.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/inithist.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/inithist.F	(revision 428)
@@ -0,0 +1,195 @@
+      subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,nq,fileid,
+     .                    filevid)
+
+       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 day0, anne0
+      real tstep, t_ops, t_wrt
+      integer fileid, filevid
+      integer nq
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer iq
+      real rlong(iip1,jjp1), rlat(iip1,jjp1)
+      integer uhoriid, vhoriid, thoriid, zvertiid
+      integer ii,jj
+      integer zan, dayref
+C
+C  Initialisations
+C
+      pi = 4. * atan (1.)
+      str='q  '
+      ctrac = 'traceur   '
+C
+C  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+C         
+
+      zan = anne0
+      dayref = day0
+      CALL ymds2ju(zan, 1, dayref, 0.0, zjulian)
+      tau0 = itau_dyn
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+       
+      call histbeg(infile, iip1, rlong(:,1), jjp1, rlat(1,:),
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, uhoriid, fileid)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg('dyn_histv.nc', iip1, rlong(:,1), jjm, rlat(1,:),
+     .             1, iip1, 1, jjm,
+     .             tau0, zjulian, tstep, vhoriid, filevid)
+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','-',
+     .              llm, nivsigs, zvertiid)
+C Pour le fichier V
+      call histvert(filevid, 'sig_s', 'Niveaux sigma','-',
+     .              llm, nivsigs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+C
+C  Vents U
+C
+      call histdef(fileid, 'ucov', 'vents u covariants', 'm/s',
+     .             iip1, jjp1, uhoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Vents V
+C
+      call histdef(filevid, 'vcov', 'vents v covariants', 'm/s',
+     .             iip1, jjm, vhoriid, 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  Geopotentiel
+C
+      call histdef(fileid, 'phi', 'geopotentiel instantane', '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Traceurs
+C
+      IF(nq.GE.1) THEN
+        DO iq=1,nq
+          IF ( iq.LE.9 ) THEN
+            WRITE(str(2:2),'(i1.1)') iq
+            write(ctrac(9:9),'(i1.1)') iq
+          ELSE
+            WRITE(str(2:3),'(i2.2)') iq
+            write(ctrac(9:10),'(i2.2)') iq
+          ENDIF
+          call histdef(fileid, str, ctrac, '-',
+     .             iip1, jjp1, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'inst(X)', t_ops, t_wrt)
+        enddo
+      endif
+C
+C  Masse
+C
+      call histdef(fileid, 'masse', 'masse', 'kg',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Pression au sol
+C
+      call histdef(fileid, 'phis', 'geopotentiel au sol', '-',
+     .             iip1, jjp1, thoriid, 1, 1, 1, -99,
+     .             32, 'inst(X)', t_ops, t_wrt)
+C
+C  Fin
+C
+      call histend(fileid)
+      call histend(filevid)
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/lnblnk.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/lnblnk.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/lnblnk.F	(revision 428)
@@ -0,0 +1,36 @@
+      INTEGER FUNCTION lnblnk (letter)
+
+C--------------------------------------------------------
+C Fonction qui determine la longeur d'un string sans les
+C blancs qui suivent. Le critere pour determiner la fin du
+C string est, trois blancs de suite
+C---------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     letter: CHARACTER*xxx (xxx < imax)
+C             le string dont on determine la longuer
+C     lnblnk: INTEGER
+C             le nombre de characteres
+C
+C     PARAMETER
+C     +++++++++
+C     imax : INTEGER
+C            le nombre maximale de character que peut contenir le string
+C            a traiter
+
+      IMPLICIT NONE
+      INTEGER i,imax
+      PARAMETER (imax = 256)
+      CHARACTER*256 letter
+
+      i=0
+
+10    i=i+1
+      IF (letter(i:i+3) . EQ . '   ') GOTO 20
+      GOTO 10
+
+20    lnblnk=i-1
+
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writedynav.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writedynav.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writedynav.F	(revision 428)
@@ -0,0 +1,147 @@
+      subroutine writedynav( histid, nq, time, vcov, 
+     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      nqmx: nombre maxi de traceurs
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1*llm),phi(ip1jmp1,llm),ppk(ip1jmp1*llm)                  
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll
+      character*3 str
+      real us(ip1jmp1*llm), vs(ip1jmp1*llm)
+      real tm(ip1jmp1*llm)
+      REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) 
+      logical ok_sync
+      integer itau_w
+C
+C  Initialisations
+C
+      str='q  '
+      ndex3d = 0
+      ndex2d = 0
+      ok_sync = .TRUE.
+      us = 999.999
+      vs = 999.999
+      tm = 999.999
+      vnat = 999.999
+      unat = 999.999
+      itau_w = itau_dyn + time
+
+C Passage aux composantes naturelles du vent
+      call covnat(llm, ucov, vcov, unat, vnat)
+
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U scalaire
+C
+      call gr_u_scal(llm, unat, us)
+      call histwrite(histid, 'u', itau_w, us, 
+     .               iip1*jjp1*llm, ndex3d)
+C
+C  Vents V scalaire
+C
+      call gr_v_scal(llm, vnat, vs)
+      call histwrite(histid, 'v', itau_w, vs, 
+     .               iip1*jjp1*llm, ndex3d)
+C
+C  Temperature potentielle moyennee
+C
+      call histwrite(histid, 'theta', itau_w, teta, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Temperature moyennee
+C
+      do ii = 1, ijp1llm
+        tm(ii) = teta(ii) * ppk(ii)/cpp
+      enddo
+      call histwrite(histid, 'temp', itau_w, tm, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi, 
+     .                iip1*jjp1*llm, ndex3d)
+C
+C  Traceurs
+C
+      IF(nq.GE.1) THEN
+        DO iq=1,nq
+          IF ( iq.LE.9 ) THEN
+            WRITE(str(2:2),'(i1.1)') iq
+          ELSE
+            WRITE(str(2:3),'(i2.2)') iq
+          ENDIF
+          call histwrite(histid, str, itau_w, q(:,:,iq), 
+     .                   iip1*jjp1*llm, ndex3d)
+        enddo
+      endif
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d)
+C
+C  Pression au sol
+C
+       call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+C
+C  Geopotentiel au sol
+C
+       call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) call histsync(histid)
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writehist.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writehist.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writehist.F	(revision 428)
@@ -0,0 +1,133 @@
+      subroutine writehist( histid, histvid, nq, time, vcov, 
+     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+      USE ioipsl
+      implicit none
+
+C
+C   Ecriture du fichier histoire au format IOIPSL
+C
+C   Appels succesifs des routines: histwrite
+C
+C   Entree:
+C      histid: ID du fichier histoire
+C      histvid:ID du fichier histoire pour les vents V (appele a disparaitre)
+C      nqmx: nombre maxi de traceurs
+C      time: temps de l'ecriture
+C      vcov: vents v covariants
+C      ucov: vents u covariants
+C      teta: temperature potentielle
+C      phi : geopotentiel instantane
+C      q   : traceurs
+C      masse: masse
+C      ps   :pression au sol
+C      phis : geopotentiel au sol
+C      
+C
+C   Sortie:
+C      fileid: ID du fichier netcdf cree
+C
+C   L. Fairhead, LMD, 03/99
+C
+C =====================================================================
+C
+C   Declarations
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+
+C
+C   Arguments
+C
+
+      INTEGER histid, nq, histvid
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL phis(ip1jmp1)                  
+      REAL q(ip1jmp1,llm,nq)
+      integer time
+
+
+C   Variables locales
+C
+      integer iq, ii, ll
+      integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1)
+      character*3 str
+      logical ok_sync
+      integer itau_w
+C
+C  Initialisations
+C
+      str='q  '
+      ndexu = 0
+      ndexv = 0
+      ndex2d = 0
+      ok_sync =.TRUE.
+      itau_w = itau_dyn + time
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      call histwrite(histid, 'ucov', itau_w, ucov, 
+     .               iip1*jjp1*llm, ndexu)
+
+C
+C  Vents V
+C
+      call histwrite(histvid, 'vcov', itau_w, vcov, 
+     .               iip1*jjm*llm, ndexv)
+
+C
+C  Temperature potentielle
+C
+      call histwrite(histid, 'teta', itau_w, teta, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', itau_w, phi, 
+     .                iip1*jjp1*llm, ndexu)
+C
+C  Traceurs
+C
+      IF(nq.GE.1) THEN
+        DO iq=1,nq
+          IF ( iq.LE.9 ) THEN
+            WRITE(str(2:2),'(i1.1)') iq
+          ELSE
+            WRITE(str(2:3),'(i2.2)') iq
+          ENDIF
+          call histwrite(histid, str, itau_w, q(:,:,iq), 
+     .                   iip1*jjp1*llm, ndexu)
+        enddo
+      endif
+C
+C  Masse
+C
+      call histwrite(histid, 'masse', itau_w, masse, iip1*jjp1, ndex2d)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', itau_w, ps, iip1*jjp1, ndex2d)
+C
+C  Geopotentiel au sol
+C
+      call histwrite(histid, 'phis', itau_w, phis, iip1*jjp1, ndex2d)
+C
+C  Fin
+C
+      if (ok_sync) then
+        call histsync(histid)
+        call histsync(histvid)
+      endif
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writephys.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writephys.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/bibio/writephys.F90	(revision 428)
@@ -0,0 +1,393 @@
+!
+! $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
+  integer              :: itau_deb
+!
+! 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(:,1), jjm, temp_lat(1,:), &
+     &                 1, iim, 1, jjm, itau_deb, 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/IPSL-CM4_v1x1/libf/dyn3d/LISEZMOI
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/LISEZMOI	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/LISEZMOI	(revision 428)
@@ -0,0 +1,281 @@
+
+ ..  Version  du 28/12/1998  , avec  nouveau fxyhyper appele par inigeom ...
+c
+c
+ 
+   La dynamique  de LMDZ.3.2  est pratiquement identique  a celle de 
+                    LMDZ.3   .
+
+  Elle ne differe , en gros , que par   :
+
+ a ) etat0_lmd   ( on doit introduire , en plus de dayref qui est le jour
+     -----------
+      de l'etat initial cree ,  anneeref  , qui est l'annee correspondante
+      et qui servira eventuellement  a lire la bonne annee pour le fichier
+      limit.dat , dic  ) . Il y a aussi le  stockage des coefficients pour
+      l'orographie  de Francois Lott , sur startphy .  
+
+ b ) calfis  qui prepare l'interface avec la physique  qui a ete restruc-
+     -------
+     turee  par Laurent Li , dans ses grandes lignes , et qui est maintenant
+
+     adaptee pour les traceurs avec l'ajout du shema de convection de Tiedtke. 
+   
+     Pour plus de details concernant le cote pratique des simulations avec
+     cette bib.  , priere de se reporter a la fin  de ce  LISEZMOI .
+
+
+ **************************************************************************
+
+ 1) Le gcm LMDZ.3.2  a des coordonnees  hybrides  verticalement ,c.a.d  des
+          ********
+   coordonnees equivalentes a sigma pres de la surface et a  P plus haut .     
+
+   Les pressions  p(ij,l) aux differents interfaces des  llm  couches verti- 
+   cales sont donnees  par   :
+
+    p( ij,l ) = ap(l) + bp(l) * ps(ij)    ,    1 << l << llm + 1    . 
+
+                  avec   bp(l) =  EXP ( 1. - 1./ sigma(l) ** 2 )
+                         ap(l) =  pa * (  sigma(l) -  bp(l)  )
+
+                    pa   est actuellement mis a  50 000.  Pascals .
+            
+   La fonction d'Exner  est calculee aux milieux des llm couches vertic.
+
+     pk(ij,l) = cp * ( p(ij,l)/preff ) ** kappa   ,  1 << l <<  llm
+
+   Les pressions  PLS(ij,l)  definies aux milieux des couches sont egales a :
+
+     pls(ij,l) = preff * ( pk(ij,l) /cp ) ** 1./kappa
+
+   (  preff = 101 325. Pascals  dans  etat0_lmd.F  actuellement  )
+   
+
+ 2) Une des variables prognostiques de LMDZ.3  est   teta  , temperature 
+     potentielle  :    
+
+                 teta (ij,l) = temperature(ij,l) * cp/ pk(ij,l)
+ 
+N.b : Les parametres  PA et PREFF  figurent dans l'entete des fichiers
+***   start ( et restart) et histphy ,  ainsi que  AP(l) et BP(l)  .
+
+    Y figurent aussi  PRESNIVS(l) qui donnent les valeurs approximatives
+    des pressions aux milieux des couches , ainsi que  SIG_S(l) qui donnent
+    simplement les indices des llm couches et dont  la presence  permet 
+    d'utiliser tel quel  le logiciel ' wrctl '  de LMDZ.2.2 qui permet de  
+    fabriquer a partir du fichier ' histphy' ( dat et dic ) le  histphy.ctl  
+    pret a etre exploite  par  GrADS .
+
+   Les pressions PLS(ij,l)  sont stockees sur le fichier ' histphy ' car
+   elles sont indispensables quand on veut faire une interpolation des varia-
+   bles d'analyse comme  u, v ,teta  a des valeurs determinees de la pression.
+   Elles figurent aussi eventuellement sur le fichier histins.gdat (.ctl ) 
+   qui renferme des etats instantanes .
+   Voir le parametre ok_inst dans physiq.f  ( L.Li ) .
+
+   Un exemple d'interpolation de u,v, et teta  se trouve  dans le fichier 
+   'analyse_lmdz_hyb' du repertoire de la dynamique , analyse_hyb etant 
+   adapte d'un fichier d'analyse de histphy  de  Laurent Li .
+    
+ 3) Dans  le programme principal gcm.F , il faut definir , au debut ,les para-
+    metres  IADV ,pour choisir le shema d'advection pour l'eau et les traceurs
+               :    IADV = 1    , humidite specifique
+                    IADV = 2    , shema    amont
+                    IADV = 3    , Van-Leer
+
+ 4) Il y a 2 shemas de dissipation   ( diffusion laterale )  :
+
+ a) La dissipation star ( qui ne fait pas intervenir la geometrie de la     
+    grille et qui est utilisee quand il y a un zoom ) 
+
+    Par expl . la diffusion d'un scalaire  comme  teta est formulee ( en 
+     appelant l'operateur  DIVGRAD2 )   comme :
+
+    d( ro * teta ) = (-1)**(it-1) *cdiv * Lap * ro**1/2 * Lap_gam** (it-2 ) *
+                           ro**1/2 * Lap * teta
+ avec  :
+ Lap     = 1/aire * Filt[ dx ( coefx*dx ) + dy( coefy*dy ) ] Filt
+       
+ Lap_gam = (1./aire)** -gam { dx[ coefx**(-gam) dx] + dy[ coefy**(-gam) dy ] } 
+
+
+  Filt est l'operateur  filtre 
+  ro   est la densite dp  de chaque couche
+  it   = nombre d'iterations de l'operateur de dissipation ( ici divgrad2 )
+  gam  = coefdis /( it -2 ) , coefdis = 0. si it = 2 , sinon = 1. habituellem.
+  dx   = operateur difference finie :
+    dx(A) = A( X +1/2 , Y, z ) - A( X -1/2, Y, z ) , dans le systeme de 
+  travail  (X,Y) , avec l'increment DX = 1.
+
+  Idem pour dy .
+
+  coefx = beta(ij) / alpha(ij)  , coefy = alpha(ij)/beta(ij)
+     avec    u_covariant(ij) = alpha(ij)* u_nat(ij) 
+             v_covariant(ij) = beta(ij) * v_nat(ij) 
+
+ Cette dissipation star est choisie en mettant le parametre lstardis a .TRUE.
+  dans le fichier run.def  lu  par le gcm en entree .
+
+ b) La dissipation ' non star '  fait intervenir les operateurs elementaires
+   diverg,grad,rotat .   Elle est choisie  avec lstardis = .FALSE.
+
+N.B : Dans les 2 shemas de dissipation , le gcm est plus stable  quand on
+     n'itere pas l'operateur ' GRADIV ' ou ' GRADIV2 " .            
+     
+ 5) Les constantes thermodynamiques Cp et kappa = R/Cp   utilisees dans la
+   partie dynamique ont ete mises , ce qui est normal, aux memes valeurs
+   qu'elles ont dans la partie ' physique ' , en changeant INICONST et en 
+   les mettant dans l'entete de controle de start et startphy ,en changeant
+   etat0_lmd , par rapport  a LMDZ.2.2 
+       
+ 6) Pour finir , quelques commentaires sur les parametres qui figurent sur
+    le fichier  run.def qui commandent le gcm .
+
+  Dans le run.def donne en exemple dans /users/SOURCES/LMDZ.3/libf/dyn3d  ,
+
+ a) day_step  correspond a un  dt  de  2 minutes .
+
+ b) idissip correspond a a un appel de la dissipation toutes les 30 minutes.
+
+N.B : Maintenant la routine inidissip calcule la meilleure valeur pour
+  idissip , en fonction des valeurs de tetagdiv , tetagrot et tetatemp qui
+  representent les temps de dissipation desirees pour dissiper les plus peti-
+  tes longueurs d'ondes pour u ,v et teta  dans le cas, respectivement des 
+  operateurs gradiv (gradiv2) , nxgrarot (nxgraro2) et divgrad ( divgrad2) .
+
+ c) coefdis , coefficient qui intervient dans le calcul de gam  , utilise 
+   dans les routines de dissipation star , vus plus haut .
+
+ d) iphysiq correspond ici a un appel de la physique toutes les 30 minutes.
+
+ e) alphax et alphay correspondent au grossissement pour le zoom dans la
+   direction X et Y .
+   En fait , les facteurs de grossissement sont egaux a  1./ ( 1.- alphax )
+     et 1./( 1.- alphay )  .
+
+ f) fxyhypb  est egal a .TRUE. si on choisit  pour la fonction f(x,y) qui 
+   definit la grille du modele  une fonction a tangente hyperbolique , un peu
+   adaptee pour le zoom , que la fonction sinusoidale , definie par fxy_new.h 
+   dans /..../gcm/libf/grid  et lu par  makegcm  lors de la compilation du 
+   code .
+
+
+N.B: Pour l'instant , cette fonction hyperbolique n'est activee eventuellement
+****            que pour  un zoom  latitudinal . 
+   Pour un zoom longitudinal , la fonction sinusoidale precisee dans fxy_new.h
+       est  choisie automatiquement .
+
+ g) psi0 et delta sont des parametres  pour cette fonction hyberbolique .
+   Ces valeurs de 0.3 et 0.5  ont ete adaptees pour 96x72  .
+  
+
+
+ 7) La partie 'physique'  est quasiment  identique a celle de  LMDZ.2.2 
+             ***********
+    ( /users/lmdz/SOURCES/LMDZ.2.2/libf/phylmd ) geree par  Laurent Li
+
+    sauf  PHYSIQ.F ( ou il y a l'ecriture en plus de pls  sur 'histphy' et 
+    histins  ) et   PHYETAT0.F et PHYREDEM.F  ou il y a l'argument  RLON
+    en plus  dans le tableau des aurguments  et WRITEFIA  ou nivsigs rempla-
+    sig_s  pour les niveaux verticaux .   
+
+
+ ****************************************************************************
+
+ 
+ AA) Choisir les options du run  , avec   le fichier  run.def   .
+
+     Il y a entre autres choses , le nombre de jours qu'on veut integrer lors 
+       d'un run .
+     Il y a le nombre de pas a faire pour 1 jour , ce qui calcule donc le dt
+       temporel ( en secondes ) pour un pas dynamique .
+     Iperiod  est conseille  d'etre a 5 pas ( mais non obligatoiremnet = 5 ) . 
+     Idissip  peut etre mis a n'importe quelle valeur . Il est maintenant
+     calcule dans inidissip de telle facon a optimiser  sa valeur .
+
+     Les parametres( la plupart des cles ) pour la physique commencent avec
+      la var. logique         **  physic  **
+
+           entiere( en pas )  ** iphysiq  ** qui est calculee de telle facon a
+                              appeler la physique tous les  30 minutes .
+
+           ( en jours )       ** ecritphy ** qui indique la frequence en jours
+                                du stockage   sur   histphy .  
+
+      les variables logiques  ** cycle_diurne **  pour le cycle diurne
+
+                              ** soil_model  **   pour un modele pour le sol
+
+                              ** new_oliq   **  pour une nouvelle formulation
+            pour l'eau liquide nuageuse , utilisee dans les rayonnements .
+
+                              ** ok_orodr **   si on appelle l'orographie
+                              ** ok_orolf **        IDEM
+
+                              ** ok_limitvrai ** si on veut lire la bonne
+                          annee  du fichier limit .
+
+
+ Si ok_limitvrai = .TRUE.  , la routine  condsurf  de la physique  va lire
+
+ la bonne annee  des conditions limites et il faut , dans le script qui lance
+
+ le run , faire figurer  les fichiers limites attendus par le gcm .
+
+
+ PLus clairement , si on lance un run  de 30 jours ,  du 25 Decembre 1986 au
+
+ 25 Janvier  1987  ,  ( actuellement dans le Gcm , il n'y a que des mois de
+
+ 30 jours ) ,   des que le  modele  arrive au jour 360 (qui correspond au
+
+ 30 Decembre) pour aller au jour 361  ( qui correspond au 1 Janvier 1987 ) ,
+
+ il s'attend a lire le fichier  limit1987 ( avec 4 chiffres  pour l'an 2000).
+
+ Donc , dans le script du run , on devra avoir, grosso modo  :
+
+***********************************************************************
+cd $TMPDIR
+#
+cp $workdir/mod/limit86.dat limit1986.dat
+cp $workdir/mod/limit86.dic limit1986.dic
+cp $workdir/mod/limit87.dat limit1987.dat
+cp $workdir/mod/limit87.dic limit1987.dic
+#
+gcm.e < run.def
+**********************************************************************
+
+      la variable entiere   ** nbapp_rad ** qui est le nombre d'appels /jour
+                  des routines de rayonnements .
+
+      la variable entiere   ** iflag_con ** qui indique le shema de convection
+        choisi  :     1   >  LMD ,   2  > Tiedtke  ,   3  >  CCM  .
+    
+                       
+
+ BB) Creer l'etat initial , avec les donnees de l'ECMWF , en compilant 
+     etat0_lmd  , en precisant auparavant  dayref  et anneeref .
+
+
+ CC) Creer le fichier des conditions aux limites ( SST, Albedo, Rugosite,
+     Nature du sol  ) avec  si possible la concordance entre l'annee des
+     donnees des sst, albedo, etc ..  avec  les donnees pour l'etat initial .
+
+ DD)  Compiler  le Gcm , lancer le run , prendre un bon verre et attendre
+      la sortie  des resultats .
+
+
+
+                 Phu  Le Van  .
+
+                 E.N.S , 24 Rue Lhomond  , PARIS  5 ieme .
+                 Tel :  01 44 32 22 67
+
+                 4 Place Jussieu         , PARIS  5 ieme .
+                 TEL :  01 44 27 47 72
+
+                 Email :  levan@lmd.ens.fr
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/abort_gcm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/abort_gcm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/abort_gcm.F	(revision 428)
@@ -0,0 +1,36 @@
+c
+c $Header$
+c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+      USE IOIPSL
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+
+      character*20 modname
+      integer ierr
+      character*80 message
+
+      write(*,*) 'in abort_gcm'
+      call histclo
+      call restclo
+c     call getin_dump
+c     call histclo(2)
+c     call histclo(3)
+c     call histclo(4)
+c     call histclo(5)
+      write(*,*) 'out of histclo'
+      write(*,*) 'Stopping in ', modname
+      write(*,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(*,*) 'Everything is cool'
+      else
+        write(*,*) 'Houston, we have a problem ', ierr
+      endif
+      STOP
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_tend.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_tend.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_tend.F	(revision 428)
@@ -0,0 +1,46 @@
+      SUBROUTINE add_tend(n,dt,dx,xi,xf)
+c%W%	%G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 17/02/93
+c   -------
+c
+c   Subject:
+c   ------
+c   Ajout d'une tendance. OUAOUH!
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+c   Arguments:
+c   ----------
+      INTEGER n
+      REAL xi(n),dx(n),dt,xf(n)
+
+c   Local:
+c   ------
+      INTEGER i
+
+c-----------------------------------------------------------------------
+
+      DO i=1,n
+         xf(i)=xi(i)+dt*dx(i)
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_vec.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_vec.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/add_vec.F	(revision 428)
@@ -0,0 +1,8 @@
+      SUBROUTINE add_vec(n,x,y,z)
+      INTEGER n,i
+      REAL x(n),y(n),z(n)
+      DO i=1,n
+         z(i)=x(i)+y(i)
+      ENDDO
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addfi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addfi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addfi.F	(revision 428)
@@ -0,0 +1,165 @@
+      SUBROUTINE addfi(nq, pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c    Addition of the physical tendencies
+c
+c    Interface :
+c    -----------
+c
+c      Input :
+c      -------
+c      pdt                    time step of integration
+c      leapf                  logical
+c      forward                logical
+c      pucov(ip1jmp1,llm)     first component of the covariant velocity
+c      pvcov(ip1ip1jm,llm)    second component of the covariant velocity
+c      pteta(ip1jmp1,llm)     potential temperature
+c      pts(ip1jmp1,llm)       surface temperature
+c      pdufi(ip1jmp1,llm)     |
+c      pdvfi(ip1jm,llm)       |   respective
+c      pdhfi(ip1jmp1)         |      tendencies
+c      pdtsfi(ip1jmp1)        |
+c
+c      Output :
+c      --------
+c      pucov
+c      pvcov
+c      ph
+c      pts
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+c
+c    Arguments :
+c    -----------
+c
+      INTEGER nq
+
+      REAL pdt
+c
+      REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm)
+      REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nq),pps(ip1jmp1)
+c
+      REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm)
+      REAL pdqfi(ip1jmp1,llm,nq),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      PARAMETER ( qtestt = 1.0e-40 )
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c-----------------------------------------------------------------------
+
+      DO k = 1,llm
+         DO j = 1,ip1jmp1
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO  k    = 1, llm
+       DO  ij   = 1, iim
+         xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+       ENDDO
+       tpn      = SSUM(iim,xpn,1)/ apoln
+       tps      = SSUM(iim,xps,1)/ apols
+
+       DO ij   = 1, iip1
+         pteta(   ij   ,k)  = tpn
+         pteta(ij+ip1jm,k)  = tps
+       ENDDO
+      ENDDO
+c
+
+      DO k = 1,llm
+         DO j = iip2,ip1jm
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO k = 1,llm
+         DO j = 1,ip1jm
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+c
+      DO j = 1,ip1jmp1
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+ 
+      DO iq = 1, 2
+         DO k = 1,llm
+            DO j = 1,ip1jmp1
+               pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+               pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+            ENDDO
+         ENDDO
+      ENDDO
+
+      DO iq = 3, 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
+      ENDDO
+
+
+      DO  ij   = 1, iim
+        xpn(ij) = aire(   ij   ) * pps(  ij     )
+        xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+      ENDDO
+      tpn      = SSUM(iim,xpn,1)/apoln
+      tps      = SSUM(iim,xps,1)/apols
+
+      DO ij   = 1, iip1
+        pps (   ij     )  = tpn
+        pps ( ij+ip1jm )  = tps
+      ENDDO
+
+
+      DO iq = 1, 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
+            pq (   ij   ,k,iq)  = tpn
+            pq (ij+ip1jm,k,iq)  = tps
+          ENDDO
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addit.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addit.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/addit.F	(revision 428)
@@ -0,0 +1,14 @@
+      SUBROUTINE addit(np,px,py,pz)
+      IMPLICIT NONE
+
+      INTEGER np
+      REAL px(np),py(np),pz(np)
+
+      INTEGER i
+
+      DO i=1,np
+	 pz(i)=px(i)+py(i)
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_h2o.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_h2o.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_h2o.F	(revision 428)
@@ -0,0 +1,131 @@
+      SUBROUTINE adv_h2o (nq,iq,q,w, pbaru, pbarv,dq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / F.Forget
+c   -------
+c
+c   ********************************************************************
+c   Transport d'un traceur q par shema amont (horiz), moy arithmetique (vert)
+c   (Shema classique pour l'humidite specifique LMD)
+c   ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+      INTEGER nq,iq
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq), dq( ip1jmp1,llm,nq )
+      REAL w(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      INTEGER   l,ij
+
+      REAL qbyv( ip1jm,llm ), qbxu( ip1jmp1,llm )
+      REAL wsur2(ip1jmp1),ww
+      REAL dqh( ip1jmp1,llm)
+
+      EXTERNAL     convflu
+
+c     ----------------------------------------------------------------
+c     --        calcul transport horiz. pour  dq                    --
+c     -                                                              -
+c     -         shema ' amont '  pour l'humidite specifique  q       -
+c     ----------------------------------------------------------------
+c
+      IF( iq.GT.2 )   THEN
+        DO   l = 1, llm
+         DO ij = 1, ip1jmp1
+          dq(ij,l,iq) = 0.
+         ENDDO
+        ENDDO
+            RETURN
+      ENDIF
+
+ 
+      IF( forward.OR.leapf )   THEN
+ 
+        DO 10 l = 1, llm
+ 
+        DO 6  ij     = iip2, ip1jm - 1
+ 
+          IF( pbaru(ij,l).GT.0.  )   THEN
+            qbxu( ij,l ) =  pbaru( ij,l )  * q(  ij  ,l,iq)
+          ELSE
+            qbxu( ij,l ) =  pbaru( ij,l )  * q(ij +1 ,l,iq)
+          ENDIF
+
+   6    CONTINUE
+ 
+c     ..... correction  pour  qbxu(iip1,j,l)   .....
+c     ...   qbxu(iip1,j,l)= qbxu(1,j,l)  ...
+ 
+CDIR$ IVDEP
+        DO  7   ij   = iip1 +iip1, ip1jm, iip1
+        qbxu( ij,l ) = qbxu( ij - iim, l )
+   7    CONTINUE
+ 
+        DO  8  ij     = 1, ip1jm
+         IF( pbarv(ij,l).GT.0.  )   THEN
+           qbyv( ij,l ) =  pbarv( ij,l )  * q(ij+iip1, l,iq)
+         ELSE
+           qbyv( ij,l ) =  pbarv( ij,l )  * q(   ij  , l,iq)
+         ENDIF
+   8    CONTINUE
+c
+  10    CONTINUE
+c
+ 
+c     stockage dans  dqh de la convergence horiz.du flux d'humidite  .
+c     ------------------------------------------------------------- 
+c
+                  CALL  convflu(qbxu, qbyv, llm, dqh )
+
+c
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection vertic.pour q ....
+c              (moyenne arithmetique)
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dqh pour calculer dq
+c
+
+      DO 20 l = 1,llmm1
+
+c       preliminaires:
+c
+        DO 11 ij = 1,ip1jmp1
+         wsur2( ij ) = - 0.5 * w( ij,l+1 )
+  11    CONTINUE
+
+
+        DO 12 ij = 1,ip1jmp1
+          ww             = wsur2(ij)   * ( q(ij,l,iq) + q(ij,l+1,iq) )
+          dq (ij, l ,iq) = dqh(ij, l ) -  ww
+          dqh(ij,l+1   ) = dqh(ij,l+1) +  ww
+  12    CONTINUE
+c
+  20  CONTINUE 
+c
+c       special dq (ij,llm) (qui n'a pas ete rempli ! ) 
+c
+        DO  ij = 1,ip1jmp1
+          dq( ij,llm,iq ) = dqh( ij,llm ) 
+        END DO
+           
+      END IF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_hor.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_hor.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/adv_hor.F	(revision 428)
@@ -0,0 +1,52 @@
+      SUBROUTINE adv_hor(h,pbaru,pbarv,dh,lfiltre)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   ********************************************************************
+c   .... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c     h,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dh 	       sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL h( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dh( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+      EXTERNAL     convflu
+      EXTERNAL     filtreg
+      LOGICAL lfiltre
+
+
+      DO l = 1,llm
+         DO ij = iip2, ip1jm - 1
+            hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( h(ij,l) + h(ij+1,l) )
+         ENDDO
+         DO ij=1,ip1jm
+            hbyv(ij,l)=pbarv(ij,l)*0.5*(h(ij, l)+h(ij+iip1,l))
+         ENDDO
+      ENDDO
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+      CALL SCOPY(jjp1*llm,hbxu(iip1+iip1,1),iip1,hbxu(iip1+1,1),iip1)
+
+      CALL  convflu ( hbxu, hbyv, llm, dh )
+
+      IF (lfiltre) CALL filtreg(dh,jjp1,llm,2,2,.true.,1)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advect.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advect.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advect.F	(revision 428)
@@ -0,0 +1,164 @@
+      SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , Fr. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *************************************************************
+c   .... calcul des termes d'advection vertic.pour u,v,teta,q ...
+c   *************************************************************
+c        ces termes sont ajoutes a du,dv,dteta et dq .
+c  Modif F.Forget 03/94 : on retire q de advect
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "ener.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1)
+      REAL unsaire2(ip1jmp1), ge(ip1jmp1)
+      REAL deuxjour, ww, gt, uu, vv
+
+      INTEGER  ij,l
+
+      EXTERNAL  SSUM
+      REAL      SSUM
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      IF (conser)  THEN
+         deuxjour = 2. * daysec
+
+         DO   1  ij   = 1, ip1jmp1
+         unsaire2(ij) = unsaire(ij) * unsaire(ij)
+   1     CONTINUE
+      END IF
+
+
+c------------------  -yy ----------------------------------------------
+c   .  Calcul de     u
+
+      DO  l=1,llm
+         DO    ij     = iip2, ip1jmp1
+            uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) )
+         ENDDO
+         DO    ij     = iip2, ip1jm
+            uav(ij,l) = uav(ij,l) + uav(ij+iip1,l)
+         ENDDO
+         DO      ij         = 1, iip1
+            uav(ij      ,l) = 0.
+            uav(ip1jm+ij,l) = 0.
+         ENDDO
+      ENDDO
+
+c------------------  -xx ----------------------------------------------
+c   .  Calcul de     v
+
+      DO  l=1,llm
+         DO    ij   = 2, ip1jm
+          vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) )
+         ENDDO
+         DO    ij   = 1,ip1jm,iip1
+          vav(ij,l) = vav(ij+iim,l)
+         ENDDO
+         DO    ij   = 1, ip1jm-1
+          vav(ij,l) = vav(ij,l) + vav(ij+1,l)
+         ENDDO
+         DO    ij       = 1, ip1jm, iip1
+          vav(ij+iim,l) = vav(ij,l)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+c
+      DO 20 l = 1, llmm1
+
+
+c       ......   calcul de  - w/2.    au niveau  l+1   .......
+
+      DO 5   ij   = 1, ip1jmp1
+      wsur2( ij ) = - 0.5 * w( ij,l+1 )
+   5  CONTINUE
+
+
+c     .....................     calcul pour  du     ..................
+
+      DO 6 ij = iip2 ,ip1jm-1
+      ww        = wsur2 (  ij  )     + wsur2( ij+1 ) 
+      uu        = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) )
+      du(ij,l)  = du(ij,l)   - ww * ( uu - uav(ij, l ) )/massebx(ij, l )
+      du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1)
+   6  CONTINUE
+
+c     .....  correction pour  du(iip1,j,l)  ........
+c     .....     du(iip1,j,l)= du(1,j,l)   .....
+
+CDIR$ IVDEP
+      DO   7  ij   = iip1 +iip1, ip1jm, iip1
+      du( ij, l  ) = du( ij -iim, l  )
+      du( ij,l+1 ) = du( ij -iim,l+1 )
+   7  CONTINUE
+
+c     .................    calcul pour   dv      .....................
+
+      DO 8 ij = 1, ip1jm
+      ww        = wsur2( ij+iip1 )   + wsur2( ij )
+      vv        = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) )
+      dv(ij,l)  = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l )
+      dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1)
+   8  CONTINUE
+
+c
+
+c     ............................................................
+c     ...............    calcul pour   dh      ...................
+c     ............................................................
+
+c                       ---z
+c       calcul de  - d( teta  * w )      qu'on ajoute a   dh
+c                   ...............
+
+        DO 15 ij = 1, ip1jmp1
+         ww            = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) )
+         dteta(ij, l ) = dteta(ij, l )  -  ww
+         dteta(ij,l+1) = dteta(ij,l+1)  +  ww
+  15    CONTINUE
+
+      IF( conser)  THEN
+        DO 17 ij = 1,ip1jmp1
+        ge(ij)   = wsur2(ij) * wsur2(ij) * unsaire2(ij)
+  17    CONTINUE
+        gt       = SSUM( ip1jmp1,ge,1 )
+        gtot(l)  = deuxjour * SQRT( gt/ip1jmp1 )
+      END IF
+
+  20  CONTINUE
+ 
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advection.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advection.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advection.F	(revision 428)
@@ -0,0 +1,81 @@
+      SUBROUTINE advection
+     $ (ucov,vcov,h,pext,pks,pksf,phis,phi,conser,du,dv,dh,dp)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      LOGICAL conser
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),h(ip1jmp1,llm)
+      REAL pext(ip1jmp1),pks(ip1jmp1),pksf(ip1jmp1),phis(ip1jmp1)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
+
+c   Local:
+c   ------
+
+      REAL pbarx(ip1jmp1),pbary(ip1jm),pbarxy(ip1jm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm),vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+
+      INTEGER ij
+      EXTERNAL  advect,bernoui,convmas,covcont,dhdq1,dudv1,dudv2,
+     *          enercin,flumass,pbar,tourpot,vitvert,sortvarc
+
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont (llm,ucov , vcov , ucont, vcont               )
+      CALL pbar    ( pext ,pbarx , pbary, pbarxy              )
+      CALL flumass ( pbarx, pbary, vcont, ucont ,pbaru, pbarv )
+      CALL dhdq1   (   h  , pbaru, pbarv,  dh                 )
+      CALL convmas ( pbaru, pbarv, convm                      )
+
+      DO 10  ij = 1, ip1jmp1
+      dp( ij ) = convm( ij,1 )
+  10  CONTINUE
+
+      CALL vitvert ( convm , w                              )
+      CALL tourpot ( vcov  , ucov  , pbarxy  , vorpot       )
+      CALL dudv1   ( vorpot, pbaru , pbarv   , du    , dv   )
+      CALL enercin ( vcov  , ucov  , vcont   , ucont , ecin )
+      CALL bernoui ( ip1jmp1,llm,phi   , ecin  , bern       )
+      CALL dudv2   ( h     , pksf  , bern    , du    , dv   )
+
+      CALL advect  ( ucov,vcov,h,w,pbarx,pbary,du,dv,dh     )
+
+c-----------------------------------------------------------------------
+c   sorties eventuelles des variables de controle:
+c   ----------------------------------------------
+
+      IF (conser) CALL sortvarc
+     $   (ucov,h,pext,pks,phis,pbarx,pbarxy,vorpot,phi,bern,dp)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advertF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advertF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/advertF	(revision 428)
@@ -0,0 +1,67 @@
+      SUBROUTINE adv_vert(h,w,dh)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ***********************************************************
+c   .... calcul des termes d'advection vertic.
+c   ***********************************************************
+c
+c       calcul de  - d( h  * w )/ d(sigma)     qu'on ajoute a   dh
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+
+      REAL h(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+      REAL dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL wsur2(ip1jmp1), unsdsig2(llm), unspbx(ip1jm)
+      REAL deuxjour,ww,gt
+
+      INTEGER  ij,l
+
+c-----------------------------------------------------------------------
+c   2. Calculs preliminaires:
+c   -------------------------
+
+      DO 2 l = 1,llm
+      unsdsig2( l ) = 0.5 * dsig1( l )
+   2  CONTINUE
+
+
+c-----------------------------------------------------------------------
+
+      DO l = 1,llmm1
+
+         DO ij = 1,ip1jmp1
+         wsur2( ij ) = - 0.5 * w( ij,l+1 )
+         ENDDO
+   
+         DO ij = 1,ip1jmp1
+             ww        = wsur2(ij) * ( h(ij,l) + h(ij,l+1) )
+             dh(ij,l)  = dh(ij,l)   - dsig1(l)   * ww
+             dh(ij,l+1)= dh(ij,l+1) + dsig1(l+1) * ww
+         ENDDO
+   
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont.F	(revision 428)
@@ -0,0 +1,125 @@
+      SUBROUTINE amont (nq,iq,q,w, pbaru, pbarv,dq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / F.Forget
+c   -------
+c
+c   ********************************************************************
+c   Transport d'un traceur q par shema amont 3D
+c   ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+      INTEGER nq,iq  
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq), dq( ip1jmp1,llm,nq )
+      REAL w(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      INTEGER   l,ij
+
+      REAL qbyv( ip1jm,llm ), qbxu( ip1jmp1,llm )
+      REAL ww
+      REAL dqh( ip1jmp1,llm)
+
+      EXTERNAL     convflu
+
+c     ----------------------------------------------------------------
+c     --        calcul transport horiz. pour  dq                    --
+c     -                                                              -
+c     -         shema ' amont '                                      -
+c     ----------------------------------------------------------------
+c
+      IF( iq.GT.2 )   THEN
+       DO   l = 1, llm
+        DO ij = 1, ip1jmp1
+          dq(ij,l,iq) = 0.
+        ENDDO
+       ENDDO
+            RETURN
+      ENDIF
+ 
+c
+      IF( forward.OR.leapf )   THEN
+ 
+        DO 10 l = 1, llm
+ 
+        DO 6  ij     = iip2, ip1jm - 1
+           IF( pbaru(ij,l).GT.0.  )   THEN
+            qbxu( ij,l ) =  pbaru( ij,l )  * q(  ij  ,l,iq)
+           ELSE
+            qbxu( ij,l ) =  pbaru( ij,l )  * q(ij +1 ,l,iq)
+           ENDIF
+   6    CONTINUE
+ 
+c     ..... correction  pour  qbxu(iip1,j,l)   .....
+c     ...   qbxu(iip1,j,l)= qbxu(1,j,l)  ...
+ 
+CDIR$ IVDEP
+        DO  7   ij   = iip1 +iip1, ip1jm, iip1
+        qbxu( ij,l ) = qbxu( ij - iim, l )
+   7    CONTINUE
+ 
+        DO  8  ij     = 1, ip1jm
+           IF( pbarv(ij,l).GT.0.  )   THEN
+            qbyv( ij,l ) =  pbarv( ij,l )  * q(ij+iip1, l,iq)
+           ELSE
+            qbyv( ij,l ) =  pbarv( ij,l )  * q(   ij  , l,iq)
+           ENDIF
+   8    CONTINUE
+c
+  10    CONTINUE
+ 
+c     stockage dans  dqh de la convergence horiz.du flux d'humidite  .
+c     ------------------------------------------------------------- 
+c
+                  CALL  convflu(qbxu, qbyv, llm, dqh )
+
+
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection vertic.pour q. Shema amont
+c ---------------------------------------------------------------
+
+c     calcul de  - d( q   * w )    qu'on ajoute a  dqh pour calculer dq
+c
+
+       DO 20 l = 1,llmm1
+c
+         DO 11 ij = 1,ip1jmp1
+           IF( w(ij,l+1).LT.0.  )   THEN
+            ww  =   - w( ij,l+1 ) * q( ij,  l  ,iq)
+           ELSE
+            ww  =   - w( ij,l+1 ) * q( ij, l +1,iq)
+           ENDIF
+
+          dq (ij, l ,iq ) = dqh(ij, l )   -  ww
+          dqh(ij,l+1    ) = dqh(ij,l+1)   +  ww
+  11     CONTINUE
+c
+  20   CONTINUE 
+
+c
+c       special dq (ij,llm) (qui n'a pas ete rempli ! ) 
+c
+        DO  ij = 1,ip1jmp1
+          dq( ij,llm,iq ) = dqh( ij,llm )
+        END DO
+           
+      END IF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont_qsat.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont_qsat.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/amont_qsat.F	(revision 428)
@@ -0,0 +1,151 @@
+      SUBROUTINE amont_qsat (nq,iq,q,teta,pk,w, pbaru, pbarv,dq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / F.Forget
+c   -------
+c
+c   ********************************************************************
+c   Transport d'un traceur q par shema amont 3D  avec contrainte thermi-
+c           -que
+c   ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER nq,iq  
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq), dq( ip1jmp1,llm,nq )
+      REAL teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      INTEGER   l,ij
+
+      REAL qbyv( ip1jm,llm ), qbxu( ip1jmp1,llm )
+      REAL ww
+      REAL dqh( ip1jmp1,llm)
+
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL rtt,retv,r3les,r3ies,r4les,r4ies,unskappa,play
+      REAL tempe(ip1jmp1),qsat(ip1jmp1,llm),r2es
+
+      EXTERNAL     convflu
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+C
+
+
+c     ----------------------------------------------------------------
+c     --        calcul transport horiz. pour  dq                    --
+c     -                                                              -
+c     -         shema ' amont '                                      -
+c     ----------------------------------------------------------------
+ 
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+ 
+        unskappa =  1./ kappa
+
+        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   =  preff * (pk(ij,l)/cpp) ** unskappa
+          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
+
+        DO 10 l = 1, llm
+
+        DO 6  ij     = iip2, ip1jm - 1
+         IF( pbaru(ij,l).GT.0  )  THEN
+          qbxu( ij,l ) = pbaru( ij,l ) * MIN( q(ij,l,iq),qsat(ij +1,l))
+         ELSE
+          qbxu( ij,l ) = pbaru( ij,l ) * MIN( q(ij+1,l,iq),qsat(ij,l) )
+         ENDIF
+       
+   6    CONTINUE
+ 
+c     ..... correction  pour  qbxu(iip1,j,l)   .....
+c     ...   qbxu(iip1,j,l)= qbxu(1,j,l)  ...
+ 
+CDIR$ IVDEP
+        DO  7   ij   = iip1 +iip1, ip1jm, iip1
+        qbxu( ij,l ) = qbxu( ij - iim, l )
+   7    CONTINUE
+ 
+        DO  8  ij     = 1, ip1jm
+         IF( pbarv(ij,l).GT.0  )  THEN
+          qbyv(ij,l) = pbarv( ij,l ) * MIN( q(ij+iip1,l,iq),qsat(ij,l) )
+         ELSE
+          qbyv(ij,l) = pbarv( ij,l ) * MIN( q(ij,l,iq),qsat(ij+iip1,l) )
+         ENDIF
+   8    CONTINUE
+c
+  10    CONTINUE
+ 
+c     stockage dans  dqh de la convergence horiz.du flux d'humidite  .
+c     ------------------------------------------------------------- 
+c
+                  CALL  convflu(qbxu, qbyv, llm, dqh )
+
+
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection vertic.pour q. Shema amont
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dqh pour calculer dq
+c
+
+       DO 20 l = 1,llmm1
+c
+         DO 11 ij = 1,ip1jmp1
+           IF( w(ij,l+1).LT.0. )   THEN
+             ww =  -w(ij,l+1) * MIN( q(ij, l ,iq),qsat(ij ,l+1) )
+           ELSE
+             ww =  -w(ij,l+1) * MIN( q(ij,l+1,iq),qsat(ij , l ) )
+           ENDIF
+
+cc     .... Modif . P. Le Van  (26/09/95) ....
+
+          dq (ij, l ,iq ) = dqh(ij, l )   -  ww
+          dqh(ij,l+1    ) = dqh(ij,l+1)   +  ww
+  11     CONTINUE
+c
+  20   CONTINUE 
+
+c
+c       special dq (ij,llm) (qui n'a pas ete rempli ! ) 
+c
+        DO  ij = 1,ip1jmp1
+          dq( ij,llm,iq ) = dqh( ij,llm )
+        END DO
+           
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angtot.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angtot.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angtot.h	(revision 428)
@@ -0,0 +1,8 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'angtot.h
+
+      COMMON/angtot/dangdyn,dangm1,dangdis,dangdif
+
+      REAL dangdyn,dangm1,dangdis,dangdif
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angumom.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angumom.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/angumom.F	(revision 428)
@@ -0,0 +1,41 @@
+      SUBROUTINE angumom(imx,lmx,u,ang)
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+
+      INTEGER imx,lmx
+      REAL u(imx,jjp1,lmx)
+      REAL ang(imx,jjp1,lmx)
+
+      INTEGER i,j,l
+      REAL  radomeg,zcosphi(jjp1),omegcosp(jjp1)
+      REAL zrad2,c1,angsol
+
+c-----------------------------------------------------------------------
+c   moment cinetique:
+c   -----------------
+
+
+      radomeg=omeg*rad
+      DO j=2,jjm
+         zcosphi(j)=COS( rlatu(j ))
+         omegcosp(j)=radomeg*zcosphi(j)
+      ENDDO
+
+      zrad2=rad*rad
+      angsol=2./3.*zrad2*omeg
+      c1=rad/angsol
+
+      DO l = 1  ,lmx
+         DO j =2,jjm
+            DO i=1,imx
+               ang(i,j,l) =c1*(u(i,j,l)+omegcosp(j))*zcosphi(j)
+            ENDDO
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bernoui.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bernoui.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bernoui.F	(revision 428)
@@ -0,0 +1,56 @@
+      SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c     calcul de la fonction de Bernouilli aux niveaux s  .....
+c     phi  et  ecin  sont des arguments d'entree pour le s-pg .......
+c          bern       est un  argument de sortie pour le s-pg  ......
+c
+c    fonction de Bernouilli = bern = filtre de( geopotentiel + 
+c                              energ.cinet.)
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Decalrations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+c
+c   Arguments:
+c   ----------
+c
+      INTEGER nlay,ngrid
+      REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay)
+c
+c   Local:
+c   ------
+c
+      INTEGER   ijl
+      EXTERNAL  filtreg
+c
+c-----------------------------------------------------------------------
+c   calcul de Bernouilli:
+c   ---------------------
+c
+      DO 4 ijl = 1,ngrid*nlay
+         pbern( ijl ) =  pphi( ijl ) + pecin( ijl )
+   4  CONTINUE
+c
+c-----------------------------------------------------------------------
+c   filtre:
+c   -------
+c
+      CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 )
+c
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bilan_dyn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bilan_dyn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bilan_dyn.F	(revision 428)
@@ -0,0 +1,570 @@
+      SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
+     s  ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac)
+
+c   AFAIRE
+c   Prevoir en champ nq+1 le diagnostique de l'energie
+c   en faisant Qzon=Cv T + L * ...
+c             vQ..A=Cp T + L * ...
+
+      USE IOIPSL
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+
+c====================================================================
+c
+c   Sous-programme consacre à des diagnostics dynamiques de base
+c
+c 
+c   De facon generale, les moyennes des scalaires Q sont ponderees par
+c   la masse.
+c
+c   Les flux de masse sont eux simplement moyennes.
+c
+c====================================================================
+
+c   Arguments :
+c   ===========
+
+      integer ntrac
+      real dt_app,dt_cum
+      real ps(iip1,jjp1)
+      real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm)
+      real flux_u(iip1,jjp1,llm)
+      real flux_v(iip1,jjm,llm)
+      real teta(iip1,jjp1,llm)
+      real phi(iip1,jjp1,llm)
+      real ucov(iip1,jjp1,llm)
+      real vcov(iip1,jjp1,llm)
+      real trac(iip1,jjp1,llm,ntrac)
+
+c   Local :
+c   =======
+
+      integer icum,ncum
+      logical first
+      real zz,zqy,zfactv(jjm,llm)
+
+      integer nQ
+      parameter (nQ=7)
+
+
+      character*6 nom(nQ)
+      character*6 unites(nQ)
+      character*10 file
+      integer ifile
+      parameter (ifile=4)
+
+      integer itemp,igeop,iecin,iang,iu,iovap,iun
+      integer i_sortie
+
+      save first,icum,ncum
+      save itemp,igeop,iecin,iang,iu,iovap,iun
+      save i_sortie
+
+      real time
+      integer itau
+      save time,itau
+      data time,itau/0.,0/
+
+      data first/.true./
+      data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/
+      data i_sortie/1/
+
+      real ww
+
+c   variables dynamiques intermédiaires
+      REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm)
+      REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL vorpot(iip1,jjm,llm)
+      REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm)
+      REAL bern(iip1,jjp1,llm)
+
+c   champ contenant les scalaires advectés.
+      real Q(iip1,jjp1,llm,nQ)
+    
+c   champs cumulés
+      real ps_cum(iip1,jjp1)
+      real masse_cum(iip1,jjp1,llm)
+      real flux_u_cum(iip1,jjp1,llm)
+      real flux_v_cum(iip1,jjm,llm)
+      real Q_cum(iip1,jjp1,llm,nQ)
+      real flux_uQ_cum(iip1,jjp1,llm,nQ)
+      real flux_vQ_cum(iip1,jjm,llm,nQ)
+      real flux_wQ_cum(iip1,jjp1,llm,nQ)
+      real dQ(iip1,jjp1,llm,nQ)
+
+      save ps_cum,masse_cum,flux_u_cum,flux_v_cum
+      save Q_cum,flux_uQ_cum,flux_vQ_cum
+
+c   champs de tansport en moyenne zonale
+      integer ntr,itr
+      parameter (ntr=5)
+
+      character*10 znom(ntr,nQ)
+      character*20 znoml(ntr,nQ)
+      character*10 zunites(ntr,nQ)
+      integer iave,itot,immc,itrs,istn
+      data iave,itot,immc,itrs,istn/1,2,3,4,5/
+      character*3 ctrs(ntr)
+      data ctrs/'  ','TOT','MMC','TRS','STN'/
+
+      real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm)
+      real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ)
+      real zmasse(jjm,llm),zamasse(jjm)
+
+      real zv(jjm,llm),psi(jjm,llm+1)
+
+      integer i,j,l,iQ
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      character*10 infile
+
+      integer*4 day0, anne0
+      integer fileid
+      integer thoriid, zvertiid
+      save fileid
+
+      integer ndex3d(jjm*llm)
+
+C   Variables locales
+C
+      integer tau0
+      real zjulian
+      character*3 str
+      character*10 ctrac
+      integer ii,jj
+      integer zan
+C
+      real rlong(jjm),rlatg(jjm)
+
+
+
+c=====================================================================
+c   Initialisation
+c=====================================================================
+
+      time=time+dt_app
+      itau=itau+1
+
+      if (first) then
+
+
+        icum=0
+c       initialisation des fichiers
+        first=.false.
+c   ncum est la frequence de stokage en pas de temps
+        ncum=dt_cum/dt_app
+        if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then
+           print*,'Pb : le pas de cumule doit etre multiple du pas'
+           print*,'dt_app=',dt_app
+           print*,'dt_cum=',dt_cum
+           stop
+        endif
+
+        if (i_sortie.eq.1) then
+         file='dynzon'
+         call inigrads(ifile,1
+     s  ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dt_cum,file,'dyn_zon ')
+        endif
+
+        nom(itemp)='T'
+        nom(igeop)='gz'
+        nom(iecin)='K'
+        nom(iang)='ang'
+        nom(iu)='u'
+        nom(iovap)='ovap'
+        nom(iun)='un'
+
+        unites(itemp)='K'
+        unites(igeop)='m2/s2'
+        unites(iecin)='m2/s2'
+        unites(iang)='ang'
+        unites(iu)='m/s'
+        unites(iovap)='kg/kg'
+        unites(iun)='un'
+
+
+c   Initialisation du fichier contenant les moyennes zonales.
+c   ---------------------------------------------------------
+
+      infile='dynzon'
+
+      day0=0
+      zan = 0.
+
+      CALL ymds2ju(zan, 1, 1, 0.0, zjulian)
+      zjulian = zjulian + day0
+      tau0 = 0
+      
+      rlong=0.
+      rlatg=rlatv*180./pi
+       
+      call histbeg(infile, 1, rlong, jjm, rlatg,
+     .             1, 1, 1, jjm,
+     .             tau0, zjulian, dt_cum, thoriid, fileid)
+
+C
+C  Appel a histvert pour la grille verticale
+C
+      call histvert(fileid, 'presnivs', 'Niveaux sigma','mb',
+     .              llm, presnivs, zvertiid)
+C
+C  Appels a histdef pour la definition des variables a sauvegarder
+      do iQ=1,nQ
+         do itr=1,ntr
+            if(itr.eq.1) then
+               znom(itr,iQ)=nom(iQ)
+               znoml(itr,iQ)=nom(iQ)
+               zunites(itr,iQ)=unites(iQ)
+            else
+               znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ)
+               znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr)
+               zunites(itr,iQ)='m/s * '//unites(iQ)
+            endif
+         enddo
+      enddo
+
+c   Declarations des champs avec dimension verticale
+      print*,'1HISTDEF'
+      do iQ=1,nQ
+         do itr=1,ntr
+            print*,'var ',itr,iQ
+     .      ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ)
+            call histdef(fileid,znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+c   Declarations pour les fonctions de courant
+      print*,'2HISTDEF'
+          call histdef(fileid,'psi'//nom(iQ)
+     .      ,'stream fn. '//znoml(itot,iQ),
+     .      zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+      enddo
+
+
+c   Declarations pour les champs de transport d'air
+      print*,'3HISTDEF'
+      call histdef(fileid, 'masse', 'masse',
+     .             'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+      call histdef(fileid, 'v', 'v',
+     .             'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid,
+     .             32, 'ave(X)', dt_cum, dt_cum)
+c   Declarations pour les fonctions de courant
+      print*,'4HISTDEF'
+          call histdef(fileid,'psi','stream fn. MMC ','mega t/s',
+     .      1,jjm,thoriid,llm,1,llm,zvertiid,
+     .      32,'ave(X)',dt_cum,dt_cum)
+
+
+c   Declaration des champs 1D de transport en latitude
+      print*,'5HISTDEF'
+      do iQ=1,nQ
+         do itr=2,ntr
+            call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ),
+     .        zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99,
+     .        32,'ave(X)',dt_cum,dt_cum)
+         enddo
+      enddo
+
+
+      print*,'8HISTDEF'
+               CALL histend(fileid)
+
+
+      endif
+
+
+c=====================================================================
+c   Calcul des champs dynamiques
+c   ----------------------------
+
+c   énergie cinétique
+      CALL covcont(llm,ucov,vcov,ucont,vcont)
+      CALL enercin(vcov,ucov,vcont,ucont,ecin)
+
+c   moment cinétique
+      do l=1,llm
+         ang(:,:,l)=ucov(:,:,l)+constang(:,:)
+         unat(:,:,l)=ucont(:,:,l)*cu(:,:)
+      enddo
+
+      Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp
+      Q(:,:,:,igeop)=phi(:,:,:)
+      Q(:,:,:,iecin)=ecin(:,:,:)
+      Q(:,:,:,iang)=ang(:,:,:)
+      Q(:,:,:,iu)=unat(:,:,:)
+      Q(:,:,:,iovap)=q(:,:,:,1)
+      Q(:,:,:,iun)=1.
+
+
+c=====================================================================
+c   Cumul
+c=====================================================================
+c
+      if(icum.EQ.0) then
+         ps_cum=0.
+         masse_cum=0.
+         flux_u_cum=0.
+         flux_v_cum=0.
+         Q_cum=0.
+         flux_vQ_cum=0.
+         flux_uQ_cum=0.
+      endif
+
+      print*,'dans bilan_dyn ',icum,'->',icum+1
+      icum=icum+1
+
+c   accumulation des flux de masse horizontaux
+      ps_cum=ps_cum+ps
+      masse_cum=masse_cum+masse
+      flux_u_cum=flux_u_cum+flux_u
+      flux_v_cum=flux_v_cum+flux_v
+      do iQ=1,nQ
+      Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:)
+      enddo
+
+c=====================================================================
+c  FLUX ET TENDANCES
+c=====================================================================
+
+c   Flux longitudinal
+c   -----------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjp1
+               do i=1,iim
+                  flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ)
+     s            +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ))
+               enddo
+               flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ)
+            enddo
+         enddo
+      enddo
+
+c    flux méridien
+c    -------------
+      do iQ=1,nQ
+         do l=1,llm
+            do j=1,jjm
+               do i=1,iip1
+                  flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ)
+     s            +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ))
+               enddo
+            enddo
+         enddo
+      enddo
+
+
+c    tendances
+c    ---------
+
+c   convergence horizontale
+      call  convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ)
+
+c   calcul de la vitesse verticale
+      call convmas(flux_u_cum,flux_v_cum,convm)
+      CALL vitvert(convm,w)
+
+      do iQ=1,nQ
+         do l=1,llm-1
+            do j=1,jjp1
+               do i=1,iip1
+                  ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ))
+                  dQ(i,j,l  ,iQ)=dQ(i,j,l  ,iQ)-ww
+                  dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww
+               enddo
+            enddo
+         enddo
+      enddo
+ 
+      print*,'Apres les calculs fait a chaque pas'
+c=====================================================================
+c   PAS DE TEMPS D'ECRITURE
+c=====================================================================
+      if (icum.eq.ncum) then
+c=====================================================================
+
+      print*,'Pas d ecriture'
+
+c   Normalisation
+      do iQ=1,nQ
+         Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:)
+      enddo
+      zz=1./float(ncum)
+      ps_cum=ps_cum*zz
+      masse_cum=masse_cum*zz
+      flux_u_cum=flux_u_cum*zz
+      flux_v_cum=flux_v_cum*zz
+      flux_uQ_cum=flux_uQ_cum*zz
+      flux_vQ_cum=flux_vQ_cum*zz
+      dQ=dQ*zz
+
+c     print*,'1OK'
+
+c   A retravailler eventuellement
+c   division de dQ par la masse pour revenir aux bonnes grandeurs
+      do iQ=1,nQ
+         dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:)
+      enddo
+ 
+c     print*,'2OK'
+c=====================================================================
+c   Transport méridien
+c=====================================================================
+
+c   cumul zonal des masses des mailles
+c   ----------------------------------
+      zv=0.
+      zmasse=0.
+      call massbar(masse_cum,massebx,masseby)
+      do l=1,llm
+         do j=1,jjm
+            do i=1,iim
+               zmasse(j,l)=zmasse(j,l)+masseby(i,j,l)
+               zv(j,l)=zv(j,l)+flux_v_cum(i,j,l)
+            enddo
+            zfactv(j,l)=cv(1,j)/zmasse(j,l)
+         enddo
+      enddo
+
+c     print*,'3OK'
+c   --------------------------------------------------------------
+c   calcul de la moyenne zonale du transport :
+c   ------------------------------------------
+c
+c                                     --
+c TOT : la circulation totale       [ vq ]
+c
+c                                      -     -
+c MMC : mean meridional circulation [ v ] [ q ]
+c
+c                                     ----      --       - -
+c TRS : transitoires                [ v'q'] = [ vq ] - [ v q ]
+c
+c                                     - * - *       - -       -     -
+c STT : stationaires                [ v   q   ] = [ v q ] - [ v ] [ q ]
+c
+c                                              - -
+c    on utilise aussi l'intermediaire TMP :  [ v q ]
+c
+c    la variable zfactv transforme un transport meridien cumule
+c    en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte
+c
+c   --------------------------------------------------------------
+
+
+c   ----------------------------------------
+c   Transport dans le plan latitude-altitude
+c   ----------------------------------------
+
+      zvQ=0.
+      psiQ=0.
+      do iQ=1,nQ
+         zvQtmp=0.
+         do l=1,llm
+            do j=1,jjm
+c              print*,'j,l,iQ=',j,l,iQ
+c   Calcul des moyennes zonales du transort total et de zvQtmp
+               do i=1,iim
+                  zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)
+     s                            +flux_vQ_cum(i,j,l,iQ)
+                  zqy=      0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+
+     s                           Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l))
+                  zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy
+     s             /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l)))
+                  zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy
+               enddo
+c              print*,'aOK'
+c   Decomposition
+               zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l)
+               zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l)
+               zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l)
+               zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l)
+               zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l)
+               zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ)
+            enddo
+         enddo
+c   fonction de courant meridienne pour la quantite Q
+         do l=llm,1,-1
+            do j=1,jjm
+               psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ)
+            enddo
+         enddo
+      enddo
+
+c   fonction de courant pour la circulation meridienne moyenne
+      psi=0.
+      do l=llm,1,-1
+         do j=1,jjm
+            psi(j,l)=psi(j,l+1)+zv(j,l)
+            zv(j,l)=zv(j,l)*zfactv(j,l)
+         enddo
+      enddo
+
+c     print*,'4OK'
+c   sorties proprement dites
+      if (i_sortie.eq.1) then
+      do iQ=1,nQ
+         do itr=1,ntr
+            call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ)
+     s      ,jjm*llm,ndex3d)
+         enddo
+         call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ)
+     s      ,jjm*llm,ndex3d)
+      enddo
+
+      call histwrite(fileid,'masse',itau,zmasse
+     s   ,jjm*llm,ndex3d)
+      call histwrite(fileid,'v',itau,zv
+     s   ,jjm*llm,ndex3d)
+      psi=psi*1.e-9
+      call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d)
+
+      endif
+
+
+c   -----------------
+c   Moyenne verticale
+c   -----------------
+
+      zamasse=0.
+      do l=1,llm
+         zamasse(:)=zamasse(:)+zmasse(:,l)
+      enddo
+      zavQ=0.
+      do iQ=1,nQ
+         do itr=2,ntr
+            do l=1,llm
+               zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l)
+            enddo
+            zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:)
+            call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ)
+     s      ,jjm*llm,ndex3d)
+         enddo
+      enddo
+
+c     on doit pouvoir tracer systematiquement la fonction de courant.
+
+c=====================================================================
+c/////////////////////////////////////////////////////////////////////
+      icum=0                  !///////////////////////////////////////
+      endif ! icum.eq.ncum    !///////////////////////////////////////
+c/////////////////////////////////////////////////////////////////////
+c=====================================================================
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads.F	(revision 428)
@@ -0,0 +1,123 @@
+      PROGRAM avarlect
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer jour0,im,jm,nq,nday,j1,j2,delai,iexplo,nexplo,nqs
+       integer iqs,ierr
+      integer iday,irec,i,j,iq,nfichiers
+
+      real longitude(iip1),latitude(jjp1),pi
+
+      real q(iip1,jjp1,nqmx),qsum(iip1,jjp1,nqmx)
+      real qtot(iip1,jjp1),qsumtot(iip1,jjp1)
+      logical qlogic(iip1,jjp1,nqmx)
+
+      integer ilec(30),indice_st(nqmx)
+
+      integer lstr,lnblnk
+      character*3 strj
+      character*5 str5
+
+c   Lecture eventuelle d'une liste de stations
+      open(99,file='stations.def',form='formatted',status='old'
+     s   ,iostat=ierr)
+      if(ierr.eq.0) then
+         read(99,*) nqs
+         read(99,*) (indice_st(iq),iq=1,nqs)
+         close(99)
+      else
+         print*,'On utilise les 80 stations du reseau'
+         nqs=80
+         do iq=1,nqs
+            indice_st(iq)=iq
+         enddo
+      endif
+      if(nqs.gt.nqmx) stop'surdimensioner nqmx'
+
+      str5='     '
+      pi=2.*asin(1.)
+      irec=0
+
+      print*,'Nom du fichier '
+      read(*,'(a3)') strj
+      if(strj(3:3).eq." ") then
+         lstr=2
+      else
+         lstr=3
+      endif
+      print*,'Longueur de la chaine de caracteres'
+      print*,lstr
+
+      open(10,file=strj(1:lstr)//'.dat',status='new'
+     s ,form='unformatted',access='direct',recl=4*iip1*jjp1)
+      open(11,file=strj(1:lstr)//'.ctl'
+     s ,status='unknown',form='formatted')
+
+
+      do i=1,30
+         ilec(i)=0
+      enddo
+
+c   Ouverture des fichiers qj
+         open(20,file=strj(1:lstr),form='unformatted',status='old')
+         read(20) im,jm,nq,nday,longitude,latitude
+         print*,im,jm,nq,nday,'   ',strj(1:lstr)
+
+c   lecture pour rien
+         do iday=1,nday
+            call readbin(20,iip1*jjp1*nq,qlogic)
+            ilec(jour0)=ilec(jour0)+1
+            do iq=1,max(nq,80)
+               do j=1,jjp1
+                  do i=1,iip1
+                     if(qlogic(i,j,iq)) then
+                        qtot(i,j)=1.
+                     else
+                        qtot(i,j)=0.
+                     endif
+                  enddo
+               enddo
+               write(10,rec=(iday-1)*nq+iq) qtot
+            enddo
+         enddo
+
+      do i=1,iip1
+        longitude(i)=longitude(i)*180./pi
+      enddo
+
+      do j=1,jjp1
+         latitude(j)=latitude(j)*180./pi
+      enddo
+
+      write(11,'(a4,2x,a40)')
+     &       'DSET ','^'//strj(1:lstr)//'.dat'
+ 
+      write(11,'(a12)') 'UNDEF 1.0E30'
+      write(11,'(a5,1x,a40)') 'TITLE ','Titre a voir'
+      call formcoord(11,iip1,longitude,1.,.false.,'XDEF')
+      call formcoord(11,jjp1,latitude,1.,.true.,'YDEF')
+      call formcoord(11,1,0.,1.,.false.,'ZDEF')
+      write(11,'(a4,i10,a30)')
+     &       'TDEF ',nday,' LINEAR 02JAN1987 1DY '
+      write(11,'(a4,2x,i5)') 'VARS',max(nq,80)
+      do iqs=1,nqs
+         iq=iqs
+         if(iq.lt.10) then
+            write(str5(1:1),'(i1.1)') iq
+         else
+            write(str5(1:2),'(i2.2)') iq
+         endif
+         write(11,1000) 'q'//str5,0,99,'Traceurs '//str5
+      enddo
+      write(11,'(a7)') 'ENDVARS'
+
+      close(10)
+
+1000  format(a5,3x,i4,i3,x,a39)
+
+
+ 300  FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x,  'c"est a dire du
+     * jour'i7,3x'au jour'i7//)
+
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads56.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads56.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/bin2grads56.F	(revision 428)
@@ -0,0 +1,125 @@
+      PROGRAM avarlect
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+#include "stations56.h"
+
+      integer jour0,im,jm,nq,nday,j1,j2,delai,iexplo,nexplo,nqs
+       integer iqs,ierr
+      integer iday,irec,i,j,iq,nfichiers
+
+      real longitude(iip1),latitude(jjp1),pi
+
+      real q(iip1,jjp1,nqmx),qsum(iip1,jjp1,nqmx)
+      real qtot(iip1,jjp1),qsumtot(iip1,jjp1)
+      logical qlogic(iip1,jjp1,nqmx)
+
+      integer ilec(30),indice_st(nqmx)
+
+      integer lstr,lnblnk
+      character*3 strj
+      character*5 str5
+
+c   Lecture eventuelle d'une liste de stations
+      open(99,file='stations.def',form='formatted',status='old'
+     s   ,iostat=ierr)
+      if(ierr.eq.0) then
+         read(99,*) nqs
+         read(99,*) (indice_st(iq),iq=1,nqs)
+         close(99)
+      else
+         print*,'On utilise les 79 stations du reseau'
+         nqs=56
+         do iq=1,nqs
+            indice_st(iq)=iq
+         enddo
+      endif
+      if(nqs.gt.nqmx) stop'surdimensioner nqmx'
+
+      str5='     '
+      pi=2.*asin(1.)
+      irec=0
+
+      print*,'Nom du fichier '
+      read(*,'(a3)') strj
+      if(strj(3:3).eq." ") then
+         lstr=2
+      else
+         lstr=3
+      endif
+      print*,'Longueur de la chaine de caracteres'
+      print*,lstr
+
+      open(10,file=strj(1:lstr)//'.dat',status='new'
+     s ,form='unformatted',access='direct',recl=4*iip1*jjp1)
+      open(11,file=strj(1:lstr)//'.ctl'
+     s ,status='unknown',form='formatted')
+
+
+      do i=1,30
+         ilec(i)=0
+      enddo
+
+c   Ouverture des fichiers qj
+         open(20,file=strj(1:lstr),form='unformatted',status='old')
+         read(20) im,jm,nq,nday,longitude,latitude
+         print*,im,jm,nq,nday,'   ',strj(1:lstr)
+
+c   lecture pour rien
+         do iday=1,nday
+            call readbin(20,iip1*jjp1*nq,qlogic)
+            ilec(jour0)=ilec(jour0)+1
+            do iq=1,nq
+               do j=1,jjp1
+                  do i=1,iip1
+                     if(qlogic(i,j,iq)) then
+                        qtot(i,j)=1.
+                     else
+                        qtot(i,j)=0.
+                     endif
+                  enddo
+               enddo
+               write(10,rec=(iday-1)*nq+iq) qtot
+            enddo
+         enddo
+
+      do i=1,iip1
+        longitude(i)=longitude(i)*180./pi
+      enddo
+
+      do j=1,jjp1
+         latitude(j)=latitude(j)*180./pi
+      enddo
+
+      write(11,'(a4,2x,a40)')
+     &       'DSET ','^'//strj(1:lstr)//'.dat'
+ 
+      write(11,'(a12)') 'UNDEF 1.0E30'
+      write(11,'(a5,1x,a40)') 'TITLE ','Titre a voir'
+      call formcoord(11,iip1,longitude,1.,.false.,'XDEF')
+      call formcoord(11,jjp1,latitude,1.,.true.,'YDEF')
+      call formcoord(11,1,0.,1.,.false.,'ZDEF')
+      write(11,'(a4,i10,a30)')
+     &       'TDEF ',nday,' LINEAR 02JAN1987 1DY '
+      write(11,'(a4,2x,i5)') 'VARS',nq
+      do iqs=1,nqs
+         iq=i56(iqs)
+         if(iq.lt.10) then
+            write(str5(1:1),'(i1.1)') iq
+         else
+            write(str5(1:2),'(i2.2)') iq
+         endif
+         PRINT*,'iqs,i56,iq,str5',iqs,i56(iqs),iq,str5
+         write(11,1000) 'q'//str5,0,99,'Traceurs '//str5
+      enddo
+      write(11,'(a7)') 'ENDVARS'
+
+      close(10)
+
+1000  format(a5,3x,i4,i3,x,a39)
+
+
+ 300  FORMAT('1'/15x'run du pas'i7,2x,'au pas'i7,2x,  'c"est a dire du
+     * jour'i7,3x'au jour'i7//)
+
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br.F	(revision 428)
@@ -0,0 +1,78 @@
+      SUBROUTINE cal_br(nx,im,jm,px,paire,pxav)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    Frederic Hourdin         01/01/91
+c   -------
+c
+c   Objet:     Decomposition d'un champ meteorologique  sous 
+c   ------         x   =  < x >  +   x'
+c              ou < x > est la moyenne zonale du champ
+c
+c              en fait pour un champ x(nlong,nlat) on n'effectue la
+c              moyenne que sur les nomg-1 premiere longitude
+c
+c   Interface:
+c   ----------
+c
+c   Input:
+c   ------
+c
+c      nlong              nombre de longitude
+c      nlat               nombre de latitudes a decomposer
+c      px(nlong,nlat)     champ d'entre
+c
+c   Output:
+c   -------
+c
+c      pxav(nlong,nlat)   champ moyen
+c      pxst(nlong,nlat)   ecart a la moyenne
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0.Declarations:
+c   ---------------
+
+c   Arguments:
+c   ----------
+
+#include "dimensions.h"
+      INTEGER im,jm,nx
+      REAL paire(im+1,jm)
+      REAL px(im+1,jm,nx),pxav(jm,nx)
+
+c   Local:
+c   ------
+
+      REAL znorm(jjm+1)
+      INTEGER i,j,ix
+      EXTERNAL SSUM
+      REAL SSUM
+
+c-----------------------------------------------------------------------
+c   1. Initialisations:
+c   -------------------
+
+c-----------------------------------------------------------------------
+c   2. Calcul du champ moyen:
+c   -------------------------
+
+      DO j=1,jm
+         znorm(j)=1./SSUM(iim,paire(1,j),1)
+      ENDDO
+      DO ix=1,nx
+         DO j=1,jm
+            pxav(j,ix)=0.
+            DO i=1,im
+               pxav(j,ix)=pxav(j,ix)+paire(i,j)*px(i,j,ix)
+            ENDDO
+            pxav(j,ix)=pxav(j,ix)*znorm(j)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br_st.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br_st.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cal_br_st.F	(revision 428)
@@ -0,0 +1,90 @@
+      SUBROUTINE cal_br_st(nx,im,jm,px,paire,pxav,pxst)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    Frederic Hourdin         01/01/91
+c   -------
+c
+c   Objet:     Decomposition d'un champ meteorologique  sous 
+c   ------         x   =  < x >  +   x'
+c              ou < x > est la moyenne zonale du champ
+c
+c              en fait pour un champ x(nlong,nlat) on n'effectue la
+c              moyenne que sur les nomg-1 premiere longitude
+c
+c   Interface:
+c   ----------
+c
+c   Input:
+c   ------
+c
+c      nlong              nombre de longitude
+c      nlat               nombre de latitudes a decomposer
+c      px(nlong,nlat)     champ d'entre
+c
+c   Output:
+c   -------
+c
+c      pxav(nlong,nlat)   champ moyen
+c      pxst(nlong,nlat)   ecart a la moyenne
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0.Declarations:
+c   ---------------
+
+c   Arguments:
+c   ----------
+
+#include "dimensions.h"
+      INTEGER im,jm,nx
+      REAL paire(im+1,jm)
+      REAL px(im+1,jm,nx),pxav(jm,nx),pxst(im+1,jm,nx)
+
+c   Local:
+c   ------
+
+      REAL znorm(jjm+1)
+      INTEGER i,j,ix
+      EXTERNAL SSUM
+      REAL SSUM
+
+c-----------------------------------------------------------------------
+c   1. Initialisations:
+c   -------------------
+
+c-----------------------------------------------------------------------
+c   2. Calcul du champ moyen:
+c   -------------------------
+
+      DO j=1,jm
+         znorm(j)=1./SSUM(iim,paire(1,j),1)
+      ENDDO
+      DO ix=1,nx
+         DO j=1,jm
+            pxav(j,ix)=0.
+            DO i=1,im
+               pxav(j,ix)=pxav(j,ix)+paire(i,j)*px(i,j,ix)
+            ENDDO
+            pxav(j,ix)=pxav(j,ix)*znorm(j)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   3. Ecart a la moyenne:
+c   ----------------------
+
+      DO ix=1,nx
+         DO j=1,jm
+            DO i=1,im
+               pxst(i,j,ix)=px(i,j,ix)-pxav(j,ix)
+            ENDDO
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calc_uvtq.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calc_uvtq.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calc_uvtq.F	(revision 428)
@@ -0,0 +1,191 @@
+      SUBROUTINE  calc_uvtq (scalarq, plev,xtlon,ylat,champi,jlat ,
+     ,  rlon,rlat, phislmd,pslmd,tslmd,pls,pk,pks,p,   champsor   ) 
+c
+c     Auteur :  P. Le Van  
+cc
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "para_netcdf.h"
+
+      INTEGER  jlat
+
+      LOGICAl scalarq
+      REAL*8  plev(levs)
+      REAL    xtlon(lons),ylat(lats),champi(lons,lats,levs)
+      REAL    phislmd(iip1,jlat),rlon(iip1),rlat(jlat) ,
+     ,        pslmd(iip1,jlat),tslmd(iip1,jlat),pls(iip1,jlat,llm) ,
+     ,        pk(iip1,jlat,llm),pks(iip1,jlat),p(iip1,jlat,llmp1) ,
+     ,        champsor(iip1,jlat,llm),alpha(iip1,jjp1,llm),
+     ,        beta(iip1,jjp1,llm),pkf(iip1,jjp1,llm)
+c
+c
+      REAL champint(iip1,jjp1)
+      LOGICAL invlev,invlon,invlat
+      REAL  pmbar
+      INTEGER ip180
+      COMMON/invlog/invlev,invlon,invlat,ip180,pmbar
+
+      REAL  ps,phisol,ts
+      COMMON/deuxD/ps(lons,lats),phisol(lons,lats),ts(lons,lats)
+  
+      INTEGER l,i,j,lll,ind,iipjlat
+c
+      REAL uu(lons,lats,levs)
+      REAL phisolmd(iip1,jjp1)
+      SAVE phisolmd
+      REAL ax(levs),ay(levs),yder(levs),bx,by
+      REAL champhor(iip1,jjp1,levs)
+      REAL prefkap,unskap
+
+      EXTERNAL grille_m, gr_int_dyn, pression, exner_hyb, spline, splint 
+c
+
+      IF( scalarq )  GO TO 100
+
+       CALL grille_m(lons, lats, xtlon, ylat, ps ,
+     ,               iim, jlat, rlon, rlat, champint )
+
+
+       CALL gr_int_dyn(champint, pslmd, iim, jlat )
+
+       CALL grille_m(lons, lats, xtlon, ylat, phisol,
+     ,             iim, jlat, rlon, rlat, champint  )
+       CALL gr_int_dyn(champint, phisolmd, iim, jlat )
+
+       CALL grille_m(lons, lats, xtlon, ylat, ts,
+     ,             iim, jlat, rlon, rlat, champint)
+       CALL gr_int_dyn(champint, tslmd, iim, jlat  )
+
+       DO j = 1, jlat
+       DO i = 1, iim
+        pslmd(i,j)    = pslmd(i,j)*( 1.0+ (phisolmd(i,j)-phislmd(i,j))
+     ,                             /287.0/tslmd(i,j))
+       ENDDO
+        pslmd(iip1,j) = pslmd(1,j)
+       ENDDO
+
+       iipjlat = iip1 * jlat
+       CALL pression( iipjlat, ap, bp, pslmd, p )
+
+       CALL exner_hyb(iipjlat,pslmd,p,alpha,beta,pks,pk,pkf )
+
+
+c    ....  Calcul de pls , pression au milieu des couches ,en Pascals ....
+c
+      PRINT *,' Pref kappa unskap  ',preff,kappa
+
+      prefkap =  preff  ** kappa
+      unskap  =  1./ kappa
+
+       DO l = 1, llm
+        DO j = 1,jlat
+         DO i = 1, iim
+          pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+         ENDDO
+          pls(iip1,j,l) = pls(1,j,l)
+        ENDDO
+       ENDDO
+
+c
+ 100   CONTINUE
+c
+c
+       DO l = 1, levs
+        DO j = 1, lats
+          DO i= 1, lons
+           uu (i,j,l) = champi (i,j,l)
+          ENDDO
+        ENDDO
+       ENDDO
+
+        IF ( invlon )   THEN
+c
+c   .....    on tourne les longitudes  pour  avoir de - pi a pi ....
+c
+
+         DO l = 1, levs
+          DO j = 1,lats
+
+           DO i = ip180,lons
+           ind  = i-ip180 +1
+           uu (ind,j,l) = champi (i,j,l)
+           ENDDO
+   
+           DO i= ind +1,lons
+           uu (i,j,l)  = champi (i-ind,j,l)
+           ENDDO
+
+          ENDDO
+        ENDDO
+
+        ENDIF
+c
+
+c   *****   fin  de   IF(invlon)   ****
+         
+         DO l = 1, levs
+           DO j = 1, lats
+              DO i = 1, lons
+               champi (i,j,l) = uu (i,j,l)
+              ENDDO
+           ENDDO
+         ENDDO
+
+         IF ( invlat )    THEN
+
+          DO l = 1, levs
+           DO j = 1, lats
+              DO i = 1, lons
+               champi (i,lats-j+1,l) = uu (i,j,l)
+              ENDDO
+           ENDDO
+          ENDDO
+
+         ENDIF
+
+c   .....   Interpol.  horizontale  ......
+c   **************************************
+c
+      DO l = 1, levs
+
+      CALL grille_m(lons, lats, xtlon, ylat, champi(1,1,l),
+     ,               iim, jlat, rlon, rlat, champint    )
+      lll = l
+      IF( invlev) lll = levs -l +1
+      CALL gr_int_dyn(champint, champhor(1,1,lll), iim, jlat)
+c
+      ENDDO
+
+c    ...  Interpolation  verticale ....   
+c    **********************************
+c
+cc   Interpolation verticale par spline
+
+c     pmbar = 100. ( si les donnees de pression sont en mb ) ou = 1.
+c
+
+      DO j=1,jlat
+        DO  i=1,iim
+          DO l=1,levs
+            ax(l)= plev(levs-l+1) *  pmbar
+            ay(l)= champhor(i,j,levs-l+1)
+          ENDDO
+          CALL spline (ax,ay,levs,1.e30,1.e30,yder)
+          DO  l=1,llm
+           bx = pls(i,j,llm-l+1)
+            CALL splint (ax,ay,yder,levs,bx,by)
+            champsor(i,j,llm-l+1)= by
+          ENDDO
+        ENDDO
+        DO l = 1, llm
+          champsor(iip1, j, l) = champsor(1, j, l)
+        ENDDO
+      ENDDO
+
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn.F	(revision 428)
@@ -0,0 +1,120 @@
+      SUBROUTINE caldyn
+     $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $  phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      LOGICAL conser
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm)
+    
+
+      INTEGER   ij,l
+      EXTERNAL  advect,bernoui,convmas,covcont,dteta1,dudv1,dudv2,
+     *          enercin,flumass,pbar,tourpot,vitvert,sortvarc,traceur,
+     *          pression,psextbar,massdair
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      CALL psextbar (   ps   , psexbarxy                            )
+      CALL massdair (    p   , masse                                )
+      CALL massbar  (   masse, massebx , masseby                    )
+      call massbarxy(   masse, massebxy                             )
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL dteta1   (   teta , pbaru   , pbarv, dteta               )
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      CALL vitvert ( convm  , w                                  )
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL dudv1   ( vorpot , pbaru , pbarv     , du     , dv    )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+      CALL dudv2   ( teta   , pkf   , bern      , du     , dv    )
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+      ENDDO
+      ENDDO
+
+
+      CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta ) 
+
+C  WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi 
+C          probablement. Observe sur le code compile avec pgf90 3.0-1 
+
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+           IF( dv(ij,l).NE.dv(ij+iim,l) )  THEN
+c         PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov',  
+c    ,   ' dans caldyn'
+c         PRINT *,' l,  ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l)
+          dv(ij+iim,l) = dv(ij,l)
+          endif
+         enddo
+      enddo
+c-----------------------------------------------------------------------
+c   Sorties eventuelles des variables de controle:
+c   ----------------------------------------------
+
+      IF( conser )  THEN
+        CALL sortvarc
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      ENDIF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/caldyn0.F	(revision 428)
@@ -0,0 +1,89 @@
+      SUBROUTINE caldyn0
+     $ (itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     $  phi,w,pbaru,pbarv,time )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Auteur :  P. Le Van
+c
+c   Objet:
+c   ------
+c
+c   Calcul des tendances dynamiques.
+c
+c Modif 04/93 F.Forget
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   0. Declarations:
+c   ----------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL pk(iip1,jjp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL time
+
+c   Local:
+c   ------
+
+      REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1)
+      REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm)
+      REAL vorpot(ip1jm,llm)
+      REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm)
+      REAL bern(ip1jmp1,llm)
+      REAL massebxy(ip1jm,llm), dp(ip1jmp1)
+    
+
+      INTEGER   ij,l
+      EXTERNAL  advect,bernoui,convmas,covcont ,
+     *          enercin,flumass,pbar,tourpot,vitvert,sortvarc,traceur,
+     *          pression,psextbar,massdair
+
+c-----------------------------------------------------------------------
+c   Calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL pression ( ip1jmp1, ap      , bp   ,  ps  , p            )
+      CALL psextbar (   ps   , psexbarxy                            )
+      CALL massdair (    p   , masse                                )
+      CALL massbar  (   masse, massebx , masseby                    )
+      CALL massbarxy(   masse, massebxy                             )
+      CALL flumass  ( massebx, masseby , vcont, ucont ,pbaru, pbarv )
+      CALL convmas  (   pbaru, pbarv   , convm                      )
+
+      DO ij =1, ip1jmp1
+         dp( ij ) = convm( ij,1 ) / airesurg( ij )
+      ENDDO
+
+      CALL vitvert ( convm  , w                                  )
+      CALL tourpot ( vcov   , ucov  , massebxy  , vorpot         )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL bernoui ( ip1jmp1, llm   , phi       , ecin   , bern  )
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            ang(ij,l) = ucov(ij,l) + constang(ij)
+         ENDDO
+      ENDDO
+
+        CALL sortvarc0
+     $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov )
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calfis.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calfis.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/calfis.F	(revision 428)
@@ -0,0 +1,568 @@
+C
+C $Header$
+C
+      SUBROUTINE calfis(nq, lafin, rdayvrai,rday_ecri, heure,
+     $            pucov,pvcov,pteta,pq,pmasse,pps,pp,ppk,pphis,pphi,
+     $            pducov,pdvcov,pdteta,pdq,pw, clesphy0,
+     $            pdufi,pdvfi,pdhfi,pdqfi,pdpsfi                   )
+c
+c    Auteur :  P. Le Van, F. Hourdin 
+c   .........
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   1. rearrangement des tableaux et transformation
+c      variables dynamiques  >  variables physiques
+c   2. calcul des termes physiques
+c   3. retransformation des tendances physiques en tendances dynamiques
+c
+c   remarques:
+c   ----------
+c
+c    - les vents sont donnes dans la physique par leurs composantes 
+c      naturelles.
+c    - la variable thermodynamique de la physique est une variable
+c      intensive :   T 
+c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
+c    - les deux seules variables dependant de la geometrie necessaires
+c      pour la physique sont la latitude pour le rayonnement et 
+c      l'aire de la maille quand on veut integrer une grandeur 
+c      horizontalement.
+c    - les points de la physique sont les points scalaires de la 
+c      la dynamique; numerotation:
+c          1 pour le pole nord
+c          (jjm-1)*iim pour l'interieur du domaine
+c          ngridmx pour le pole sud
+c      ---> ngridmx=2+(jjm-1)*iim
+c
+c     Input :
+c     -------
+c       ecritphy        frequence d'ecriture (en jours)de histphy
+c       pucov           covariant zonal velocity
+c       pvcov           covariant meridional velocity 
+c       pteta           potential temperature
+c       pps             surface pressure
+c       pmasse          masse d'air dans chaque maille
+c       pts             surface temperature  (K)
+c       callrad         clef d'appel au rayonnement
+c
+c    Output :
+c    --------
+c        pdufi          tendency for the natural zonal velocity (ms-1)
+c        pdvfi          tendency for the natural meridional velocity 
+c        pdhfi          tendency for the potential temperature
+c        pdtsfi         tendency for the surface temperature
+c
+c        pdtrad         radiative tendencies  \  both input
+c        pfluxrad       radiative fluxes      /  and output
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+
+      INTEGER ngridmx,nq
+      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
+
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+
+c    Arguments :
+c    -----------
+      LOGICAL  lafin
+      REAL heure
+
+      REAL pvcov(iip1,jjm,llm)
+      REAL pucov(iip1,jjp1,llm)
+      REAL pteta(iip1,jjp1,llm)
+      REAL pmasse(iip1,jjp1,llm)
+      REAL pq(iip1,jjp1,llm,nqmx)
+      REAL pphis(iip1,jjp1)
+      REAL pphi(iip1,jjp1,llm)
+c
+      REAL pdvcov(iip1,jjm,llm)
+      REAL pducov(iip1,jjp1,llm)
+      REAL pdteta(iip1,jjp1,llm)
+      REAL pdq(iip1,jjp1,llm,nqmx)
+c
+      REAL pw(iip1,jjp1,llm)
+c
+      REAL pps(iip1,jjp1)
+      REAL pp(iip1,jjp1,llmp1)
+      REAL ppk(iip1,jjp1,llm)
+c
+      REAL pdvfi(iip1,jjm,llm)
+      REAL pdufi(iip1,jjp1,llm)
+      REAL pdhfi(iip1,jjp1,llm)
+      REAL pdqfi(iip1,jjp1,llm,nqmx)
+      REAL pdpsfi(iip1,jjp1)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+c    Local variables :
+c    -----------------
+
+      INTEGER i,j,l,ig0,ig,iq
+      REAL zpsrf(ngridmx)
+      REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm)
+      REAL zphi(ngridmx,llm),zphis(ngridmx)
+c
+      REAL zufi(ngridmx,llm), zvfi(ngridmx,llm)
+      REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqmx)
+c
+      REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm)
+      REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2)
+c
+      REAL pvervel(ngridmx,llm)
+c
+      REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm)
+      REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqmx)
+      REAL zdpsrf(ngridmx)
+      REAL zcufi(ngridmx),zcvfi(ngridmx)
+c
+      REAL zsin(iim),zcos(iim),z1(iim)
+      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
+      REAL unskap, pksurcp
+c
+      
+      EXTERNAL gr_dyn_fi,gr_fi_dyn
+      EXTERNAL physiq,multipl
+      REAL SSUM
+      EXTERNAL SSUM
+
+      REAL latfi(ngridmx),lonfi(ngridmx)
+      REAL airefi(ngridmx)
+      SAVE latfi, lonfi, airefi
+
+      LOGICAL firstcal, debut
+      DATA firstcal/.true./
+      SAVE firstcal,debut
+      REAL rdayvrai,rday_ecri
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+      IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         PRINT*,'STOP dans calfis'
+         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         PRINT*,'  ngridmx  jjm   iim   '
+         PRINT*,ngridmx,jjm,iim
+         STOP
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   latitude, longitude et aires des mailles pour la physique:
+c   ----------------------------------------------------------
+
+c
+      IF ( firstcal )  THEN
+          debut = .TRUE.
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+c
+      IF (firstcal) THEN
+         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'
+         CALL inifis(ngridmx,llm,daysec,day_ini,dtphys ,
+     ,                latfi,lonfi,airefi,rad,g,r,cpp     )
+	  ENDIF
+
+c
+c-----------------------------------------------------------------------
+c   40. transformation des variables dynamiques en variables physiques:
+c   ---------------------------------------------------------------
+
+c   41. pressions au sol (en Pascals)
+c   ----------------------------------
+
+       
+      zpsrf(1) = pps(1,1)
+
+      ig0  = 2
+      DO j = 2,jjm
+         CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 )
+         ig0 = ig0+iim
+      ENDDO
+
+      zpsrf(ngridmx) = pps(1,jjp1)
+
+
+c   42. pression intercouches :
+c
+c   -----------------------------------------------------------------
+c     .... zplev  definis aux (llm +1) interfaces des couches  ....
+c     .... zplay  definis aux (  llm )    milieux des couches  .... 
+c   -----------------------------------------------------------------
+
+c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
+c
+       unskap   = 1./ kappa
+c
+      DO l = 1, llmp1
+        zplev( 1,l ) = pp(1,1,l)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              zplev( ig0,l ) = pp(i,j,l)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        zplev( ngridmx,l ) = pp(1,jjp1,l)
+      ENDDO
+c
+c
+
+c   43. temperature naturelle (en K) et pressions milieux couches .
+c   ---------------------------------------------------------------
+
+      DO l=1,llm
+
+         pksurcp     =  ppk(1,1,l) / cpp
+         zplay(1,l)  =  preff * pksurcp ** unskap
+         ztfi(1,l)   =  pteta(1,1,l) *  pksurcp
+         pcvgt(1,l)  =  pdteta(1,1,l) * pksurcp / pmasse(1,1,l)
+         ig0         = 2
+
+         DO j = 2, jjm
+            DO i = 1, iim
+              pksurcp        = ppk(i,j,l) / cpp
+              zplay(ig0,l)   = preff * pksurcp ** unskap
+              ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
+              pcvgt(ig0,l)   = pdteta(i,j,l) * pksurcp / pmasse(i,j,l)
+              ig0            = ig0 + 1
+            ENDDO
+         ENDDO
+
+         pksurcp       = ppk(1,jjp1,l) / cpp
+         zplay(ig0,l)  = preff * pksurcp ** unskap
+         ztfi (ig0,l)  = pteta(1,jjp1,l)  * pksurcp
+         pcvgt(ig0,l)  = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l)
+
+      ENDDO
+
+c   43.bis humidite specifique (en kg/kg)
+c   -------------------------------------
+
+      DO iq=1,nqmx
+         DO l=1,llm
+            zqfi(1,l,iq) = pq(1,1,l,iq)
+            ig0          = 2
+            DO j=2,jjm
+               DO i = 1, iim
+                  zqfi(ig0,l,iq)  = pq(i,j,l,iq)
+                  ig0             = ig0 + 1
+               ENDDO
+            ENDDO
+            zqfi(ig0,l,iq) = pq(1,jjp1,l,iq)
+         ENDDO
+      ENDDO
+
+c   convergence dynamique pour les traceurs "EAU"
+
+      DO iq=1,2
+         DO l=1,llm
+            pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l)
+            ig0          = 2
+            DO j=2,jjm
+               DO i = 1, iim
+                  pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l)
+                  ig0             = ig0 + 1
+               ENDDO
+            ENDDO
+            pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l)
+         ENDDO
+      ENDDO
+
+
+c   Geopotentiel calcule par rapport a la surface locale:
+c   -----------------------------------------------------
+
+      CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis)
+      DO l=1,llm
+	 DO ig=1,ngridmx
+	   zphi(ig,l)=zphi(ig,l)-zphis(ig)
+	 ENDDO
+      ENDDO
+
+c   ....  Calcul de la vitesse  verticale  ( en Pa*m*s  ou Kg/s )  ....
+c
+      DO l=1,llm
+        pvervel(1,l)=pw(1,1,l) * g /apoln
+        ig0=2
+       DO j=2,jjm
+           DO i = 1, iim
+              pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j)
+              ig0 = ig0 + 1
+           ENDDO
+       ENDDO
+        pvervel(ig0,l)=pw(1,jjp1,l) * g /apols
+      ENDDO
+
+c      CALL initial0( ngridmx*llm,pvervel )
+c
+c
+c   45. champ u:
+c   ------------
+
+      DO 50 l=1,llm
+
+         DO 25 j=2,jjm
+            ig0 = 1+(j-2)*iim
+            zufi(ig0+1,l)= 0.5 * 
+     $      ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) )
+            pcvgu(ig0+1,l)= 0.5 * 
+     $      ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) )
+            DO 10 i=2,iim
+               zufi(ig0+i,l)= 0.5 *
+     $         ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) )
+               pcvgu(ig0+i,l)= 0.5 *
+     $         ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) )
+10         CONTINUE
+25      CONTINUE
+
+50    CONTINUE
+
+
+c   46.champ v:
+c   -----------
+
+      DO l=1,llm
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+               zvfi(ig0+i,l)= 0.5 *
+     $         ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) )
+               pcvgv(ig0+i,l)= 0.5 *
+     $         ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) )
+            ENDDO
+         ENDDO
+      ENDDO
+
+
+c   47. champs de vents aux pole nord   
+c   ------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      DO l=1,llm
+
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
+         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1)
+         DO i=2,iim
+            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
+            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1)
+         ENDDO
+
+         DO i=1,iim
+            zcos(i)   = COS(rlonv(i))*z1(i)
+            zcosbis(i)= COS(rlonv(i))*z1bis(i)
+            zsin(i)   = SIN(rlonv(i))*z1(i)
+            zsinbis(i)= SIN(rlonv(i))*z1bis(i)
+         ENDDO
+
+         zufi(1,l)  = SSUM(iim,zcos,1)/pi
+         pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi
+         zvfi(1,l)  = SSUM(iim,zsin,1)/pi
+         pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi
+
+      ENDDO
+
+
+c   48. champs de vents aux pole sud:
+c   ---------------------------------
+c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
+c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
+
+      DO l=1,llm
+
+         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
+         z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm)
+         DO i=2,iim
+            z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
+            z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm)
+	 ENDDO
+
+         DO i=1,iim
+            zcos(i)    = COS(rlonv(i))*z1(i)
+            zcosbis(i) = COS(rlonv(i))*z1bis(i)
+            zsin(i)    = SIN(rlonv(i))*z1(i)
+            zsinbis(i) = SIN(rlonv(i))*z1bis(i)
+	 ENDDO
+
+         zufi(ngridmx,l)  = SSUM(iim,zcos,1)/pi
+         pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi
+         zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
+         pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+      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              )
+
+500   CONTINUE
+
+c-----------------------------------------------------------------------
+c   transformation des tendances physiques en tendances dynamiques:
+c   ---------------------------------------------------------------
+
+c  tendance sur la pression :
+c  -----------------------------------
+
+      CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi)
+c
+ccc     CALL multipl(ip1jmp1,aire,pdpsfi,pdpsfi)
+
+c   62. enthalpie potentielle
+c   ---------------------
+
+      DO l=1,llm
+
+         DO i=1,iip1
+          pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
+          pdhfi(i,jjp1,l) = cpp *  zdtfi(ngridmx,l)/ ppk(i,jjp1,l)
+         ENDDO
+
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+               pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l)
+            ENDDO
+               pdhfi(iip1,j,l) =  pdhfi(1,j,l)
+         ENDDO
+
+      ENDDO
+
+
+c   62. humidite specifique
+c   ---------------------
+
+      DO iq=1,nqmx
+         DO l=1,llm
+            DO i=1,iip1
+               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)
+               pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq)
+            ENDDO
+            DO j=2,jjm
+               ig0=1+(j-2)*iim
+               DO i=1,iim
+                  pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq)
+               ENDDO
+               pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq)
+            ENDDO
+         ENDDO
+      ENDDO
+
+c   65. champ u:
+c   ------------
+
+      DO l=1,llm
+
+         DO i=1,iip1
+            pdufi(i,1,l)    = 0.
+            pdufi(i,jjp1,l) = 0.
+         ENDDO
+
+         DO j=2,jjm
+            ig0=1+(j-2)*iim
+            DO i=1,iim-1
+               pdufi(i,j,l)=
+     $         0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j)
+            ENDDO
+            pdufi(iim,j,l)=
+     $      0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j)
+            pdufi(iip1,j,l)=pdufi(1,j,l)
+         ENDDO
+
+      ENDDO
+
+
+c   67. champ v:
+c   ------------
+
+      DO l=1,llm
+
+         DO j=2,jjm-1
+            ig0=1+(j-2)*iim
+            DO i=1,iim
+               pdvfi(i,j,l)=
+     $         0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j)
+            ENDDO
+            pdvfi(iip1,j,l) = pdvfi(1,j,l)
+         ENDDO
+      ENDDO
+
+
+c   68. champ v pres des poles:
+c   ---------------------------
+c      v = U * cos(long) + V * SIN(long)
+
+      DO l=1,llm
+
+         DO i=1,iim
+            pdvfi(i,1,l)=
+     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
+            pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i))
+     $      +zdvfi(ngridmx,l)*SIN(rlonv(i))
+            pdvfi(i,1,l)=
+     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
+            pdvfi(i,jjm,l)=
+     $      0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm)
+          ENDDO
+
+         pdvfi(iip1,1,l)  = pdvfi(1,1,l)
+         pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+
+700   CONTINUE
+
+      firstcal = .FALSE.
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/clesph0.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/clesph0.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/clesph0.h	(revision 428)
@@ -0,0 +1,8 @@
+c..include clesph0.h
+c
+       COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr ,
+     ,                ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con
+c
+       LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coefpoly.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coefpoly.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coefpoly.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/comav.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comav.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comav.h	(revision 428)
@@ -0,0 +1,3 @@
+      COMMON/comav/period_av,time0_av
+      REAL period_av ! periode de stockage en jour
+      REAL time0_av  ! date initiale de stokage en jour
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comconst.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comconst.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comconst.h	(revision 428)
@@ -0,0 +1,13 @@
+c-----------------------------------------------------------------------
+c INCLUDE comconst.h
+
+      COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,
+     * dtvr,daysec,
+     * pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr,daysec
+      REAL pi,dtphys,dtdiss,rad,r,cpp,kappa
+      REAL cotot,unsim,g,omeg
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdiss.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdiss.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdiss.h	(revision 428)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'comdiss.h'
+
+      INTEGER niter
+      REAL tetau(llm),tetah(llm),cdivu,cdivh,crot
+      LOGICAL dissipst
+
+      COMMON/comdissi/niter
+      COMMON/comdissr/tetau,tetah,cdivu,cdivh,crot
+      COMMON/comdissl/dissipst
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissip.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissip.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissip.h	(revision 428)
@@ -0,0 +1,13 @@
+c-----------------------------------------------------------------------
+c INCLUDE dissip.h
+
+      COMMON/comdissip/
+     $    lstardis,niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      LOGICAL lstardis
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissipn.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissipn.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissipn.h	(revision 428)
@@ -0,0 +1,13 @@
+c-----------------------------------------------------------------------
+c INCLUDE comdissipn.h
+
+      REAL  tetaudiv, tetaurot, tetah, cdivu, crot, cdivh
+c
+      COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm)   ,
+     1                        cdivu,      crot,         cdivh
+
+c
+c    Les parametres de ce common proviennent des calculs effectues dans 
+c             Inidissip  .
+c
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissnew.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissnew.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comdissnew.h	(revision 428)
@@ -0,0 +1,15 @@
+c-----------------------------------------------------------------------
+c INCLUDE comdissnew.h
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,
+     1                   tetagrot,tetatemp,coefdis 
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+c
+c ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+c              sur le fichier  run.def    ....
+c
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom.h	(revision 428)
@@ -0,0 +1,30 @@
+*CDK comgeom
+      COMMON/comgeom/
+     1 cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),
+     2 aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),
+     3 airev(ip1jm),unsaire(ip1jmp1),apoln,apols,
+     4 unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),
+     5 aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),
+     6 aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),
+     7 alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),
+     8 alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),
+     9 fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),
+     1 cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),
+     2 cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),
+     3 cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,
+     5 unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),
+     6 aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+c
+        REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,
+     2 apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2 
+     6 ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,
+     7 aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu
+     8 , xprimv
+c
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom2.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom2.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comgeom2.h	(revision 428)
@@ -0,0 +1,31 @@
+*CDK comgeom2
+      COMMON/comgeom/
+     1 cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm)  ,
+     2 aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1)           ,
+     3 airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols                 ,  
+     4 unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm)       ,
+     5 aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1)       ,
+     6 aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1)         ,
+     7 alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1)        ,
+     8 alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1)    ,
+     9 fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm),
+     1 rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm)  ,
+     1 cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1)                        ,
+     2 cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1),
+     3 cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) ,
+     4 unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2                ,
+     5 unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1)                  ,
+     6 unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm)
+     7 , xprimu(iip1),xprimv(iip1)
+
+c
+      REAL 
+     1 cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire
+     2 ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4     ,
+     3 alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     4 fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     5 cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1           , 
+     6 unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2     ,
+     7 unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu    ,
+     8 cusurcvu,xprimu,xprimv
+c
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comvert.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comvert.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/comvert.h	(revision 428)
@@ -0,0 +1,9 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'comvert.h'
+
+      COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm) ,
+     ,               pa,preff,nivsigs(llm),nivsig(llm+1)
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat2d.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat2d.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat2d.F	(revision 428)
@@ -0,0 +1,219 @@
+C
+C $Header$
+C
+      SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd ,
+     ,                           interbar                        )
+c
+c     Auteur :  P. Le Van
+
+c    Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que
+c       qu'on ait     - pi    a    pi    en longitude
+c       et qu'on ait   pi/2.  a - pi/2.  en latitude
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c      modifiees pour etre configurees comme ci-dessus .
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      INTEGER lons,lats
+      CHARACTER*25 title
+      REAL xd(lons),yd(lats)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons),yf(lats)
+c
+c    ***  Arguments en entree et  sortie ***
+      REAL champd(lons,lats)
+
+c   ***     Variables  locales  ***
+c
+      REAL pi,pis2,depi
+      LOGICAL radianlon, invlon ,radianlat, invlat, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind
+
+      REAL, ALLOCATABLE :: xtemp(:) 
+      REAL, ALLOCATABLE :: ytemp(:) 
+      REAL, ALLOCATABLE :: champf(:,:)
+     
+c
+c      WRITE(6,*) ' conf_dat2d  pour la variable ', title
+
+      ALLOCATE( xtemp(lons) )
+      ALLOCATE( ytemp(lats) )
+      ALLOCATE( champf(lons,lats) )
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+            radianlon = .FALSE.
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        IF ( invlon )   THEN
+
+           DO j = 1, lats
+            DO i = 1,lons
+             champf(i,j) = champd(i,j)
+            ENDDO
+           ENDDO
+
+           DO i = 1 ,lons
+            xf(i) = xtemp(i)
+           ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+           DO i=1,lons
+            IF( xf(i).GT. pi )  THEN
+            GO TO 88
+            ENDIF
+           ENDDO
+
+88         CONTINUE
+c
+           ip180 = i
+
+           DO i = 1,lons
+            IF (xf(i).GT. pi)  THEN
+             xf(i) = xf(i) - depi
+            ENDIF
+           ENDDO
+
+           DO i= ip180,lons
+            ind = i-ip180 +1
+            xtemp(ind) = xf(i)
+           ENDDO
+
+           DO i= ind +1,lons
+            xtemp(i) = xf(i-ind)
+           ENDDO
+
+c   .....    on tourne les longitudes  pour  champf ....
+c
+           DO j = 1,lats
+
+             DO i = ip180,lons
+              ind  = i-ip180 +1
+              champd (ind,j) = champf (i,j)
+             ENDDO
+   
+             DO i= ind +1,lons
+              champd (i,j)  = champf (i-ind,j)
+             ENDDO
+
+           ENDDO
+
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+
+         IF ( invlat )    THEN
+
+           DO j = 1,lats
+            yf(j) = ytemp(j)
+           ENDDO
+
+           DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j) = champd(i,j)
+             ENDDO
+           ENDDO
+
+           DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1) = champf (i,j)
+              ENDDO
+           ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+
+c        
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+
+      ENDIF
+c
+
+       DO i = 1, lons
+        xf(i) = xtemp(i)
+       ENDDO
+       DO j = 1, lats
+        yf(j) = ytemp(j)
+       ENDDO
+
+      DEALLOCATE(xtemp) 
+      DEALLOCATE(ytemp)
+      DEALLOCATE(champf)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat3d.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat3d.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_dat3d.F	(revision 428)
@@ -0,0 +1,294 @@
+C
+C $Header$
+C
+      SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf,
+     ,                                 champd , interbar             )
+c
+c     Auteur : P. Le Van
+c
+c    Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon 
+c       qu'on ait     - pi    a    pi    en longitude
+c       qu'on ait      pi/2.  a - pi/2.  en latitude
+c      et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos.
+c           (     en Pascals   ) .
+c
+c      xd et yd  sont les longitudes et latitudes initiales
+c      zd  les pressions initiales
+c
+c      xf et yf  sont les longitudes et latitudes en sortie , eventuellement
+c       modifiees pour etre configurees comme ci-dessus .
+c      zf  les pressions en sortie
+c
+c      champd   en meme temps le champ initial et  final
+c
+c      interbar = .TRUE.  si on appelle l'interpo. barycentrique inter_barxy
+c          sinon , l'interpolation   grille_m  ( grid_atob ) .
+c
+
+      IMPLICIT NONE
+ 
+c    ***       Arguments en  entree      ***
+      CHARACTER*(*) :: title
+      INTEGER lons, lats, levs
+      REAL xd(lons), yd(lats), zd(levs)
+      LOGICAL interbar
+c
+c    ***       Arguments en  sortie      ***
+      REAL xf(lons), yf(lats), zf(levs)
+
+c    ***  Arguments en entree et  sortie ***
+      REAL  champd(lons,lats,levs)
+
+c    ***  Variables locales  ***
+c
+      REAL pi,pis2,depi,presmax
+      LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc
+      REAL rlatmin,rlatmax,oldxd1
+      INTEGER i,j,ip180,ind,l
+
+      REAL, ALLOCATABLE :: xtemp(:)
+      REAL, ALLOCATABLE :: ytemp(:)
+      REAL, ALLOCATABLE :: ztemp(:)
+      REAL, ALLOCATABLE :: champf(:,:,:)
+     
+
+c      WRITE(6,*) '  Conf_dat3d  pour  ',title
+
+      ALLOCATE(xtemp(lons))
+      ALLOCATE(ytemp(lats))
+      ALLOCATE(ztemp(levs))
+
+      DO i = 1, lons
+       xtemp(i) = xd(i)
+      ENDDO
+      DO j = 1, lats
+       ytemp(j) = yd(j)
+      ENDDO
+      DO l = 1, levs
+       ztemp(l) = zd(l)
+      ENDDO
+
+      pi   = 2. * ASIN(1.) 
+      pis2 = pi/2.
+      depi = 2. * pi
+
+      IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 )  THEN
+            radianlon = .TRUE.
+            invlon    = .FALSE.
+      ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN
+            radianlon = .TRUE.
+            invlon    = .TRUE.
+      ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .FALSE.
+      ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 )   THEN
+            radianlon = .FALSE.
+            invlon    = .TRUE.
+      ELSE
+        WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+      invlat = .FALSE.
+      
+      IF( ytemp(1).LT.ytemp(lats) ) THEN
+        invlat = .TRUE.
+      ENDIF
+
+      rlatmin = MIN( ytemp(1), ytemp(lats) )
+      rlatmax = MAX( ytemp(1), ytemp(lats) )
+      
+      IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN
+             radianlat = .TRUE.
+      ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN
+             radianlat = .FALSE.
+      ELSE
+        WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier'
+     ,  , title
+      ENDIF
+
+       IF( .NOT. radianlon )  THEN
+         DO i = 1, lons
+          xtemp(i) = xtemp(i) * pi/180.
+         ENDDO
+       ENDIF
+
+       IF( .NOT. radianlat )  THEN
+         DO j = 1, lats
+          ytemp(j) = ytemp(j) * pi/180.
+         ENDDO   
+       ENDIF
+
+
+        alloc =.FALSE.
+
+        IF ( invlon )   THEN
+
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+
+            DO i = 1 ,lons
+             xf(i) = xtemp(i)
+            ENDDO
+
+            DO l = 1, levs
+             DO j = 1, lats
+              DO i= 1, lons
+               champf (i,j,l)  = champd (i,j,l)
+              ENDDO
+             ENDDO
+            ENDDO
+c
+c    ***  On tourne les longit.  pour avoir  - pi  a  +  pi  ****
+c
+            DO i=1,lons
+             IF( xf(i).GT. pi )  THEN
+              GO TO 88
+             ENDIF
+            ENDDO
+
+88          CONTINUE
+c
+            ip180 = i
+
+            DO i = 1,lons
+             IF (xf(i).GT. pi)  THEN
+              xf(i) = xf(i) - depi
+             ENDIF
+            ENDDO
+
+            DO i= ip180,lons
+             ind = i-ip180 +1
+             xtemp(ind) = xf(i)
+            ENDDO
+
+            DO i= ind +1,lons
+             xtemp(i) = xf(i-ind)
+            ENDDO
+
+c   .....    on tourne les longitudes  pour champf  ....
+c
+            DO l = 1,levs
+              DO j = 1,lats
+               DO i = ip180,lons
+                ind  = i-ip180 +1
+                champd (ind,j,l) = champf (i,j,l)
+               ENDDO
+   
+               DO i= ind +1,lons
+                champd (i,j,l)  = champf (i-ind,j,l)
+               ENDDO
+              ENDDO
+            ENDDO
+
+        ENDIF
+c
+c    *****   fin  de   IF(invlon)   ****
+         
+         IF ( invlat )    THEN
+
+           IF(.NOT.alloc)  THEN 
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+           ENDIF
+
+           DO j = 1, lats
+            yf(j) = ytemp(j)
+           ENDDO
+         
+           DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+
+            DO j = 1, lats
+              ytemp( lats-j+1 ) = yf(j)
+              DO i = 1, lons
+               champd (i,lats-j+1,l) = champf (i,j,l)
+              ENDDO
+            ENDDO
+          ENDDO
+
+
+         ENDIF
+
+c    *****  fin  de  IF(invlat)   ****
+c
+c
+      IF( interbar )  THEN
+        oldxd1 = xtemp(1)
+        DO i = 1, lons -1
+          xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) )
+        ENDDO
+          xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi )
+
+        DO j = 1, lats -1
+          ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) )
+        ENDDO
+      ENDIF
+c
+
+      invlev = .FALSE.
+      IF( ztemp(1).LT.ztemp(levs) )  invlev = .TRUE.
+
+      presmax = MAX( ztemp(1), ztemp(levs) )
+      IF( presmax.LT.1200. ) THEN
+         DO l = 1,levs
+           ztemp(l) = ztemp(l) * 100.
+         ENDDO
+      ENDIF
+
+      IF( invlev )  THEN
+
+          IF(.NOT.alloc)  THEN
+            ALLOCATE(champf(lons,lats,levs))
+            alloc = .TRUE.
+          ENDIF
+
+          DO l = 1,levs
+            zf(l) = ztemp(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champf(i,j,l) = champd(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+          DO l = 1,levs
+            ztemp(levs+1-l) = zf(l)
+          ENDDO
+
+          DO l = 1,levs
+            DO j = 1, lats
+             DO i = 1,lons
+              champd(i,j,levs+1-l) = champf(i,j,l)
+             ENDDO
+            ENDDO
+          ENDDO
+
+
+      ENDIF
+
+         IF(alloc)  DEALLOCATE(champf)
+
+         DO i = 1, lons
+           xf(i) = xtemp(i)
+         ENDDO
+         DO j = 1, lats
+           yf(j) = ytemp(j)
+         ENDDO
+         DO l = 1, levs
+           zf(l) = ztemp(l)
+         ENDDO
+
+      DEALLOCATE(xtemp)
+      DEALLOCATE(ytemp)
+      DEALLOCATE(ztemp)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_gcm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_gcm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/conf_gcm.F	(revision 428)
@@ -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 "clesphys.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  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = 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/IPSL-CM4_v1x1/libf/dyn3d/control.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/control.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/control.h	(revision 428)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'control.h'
+
+      COMMON/control/nday,day_step,
+     $              iperiod,iconser,iecri,idissip,iphysiq ,
+     $              periodav,ecritphy,iecrimoy,dayref,anneeref
+
+      INTEGER   nday,day_step,iperiod,iconser,iecri,
+     $          idissip,iphysiq,iecrimoy,dayref,anneeref
+      REAL periodav, ecritphy
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convflu.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convflu.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convflu.F	(revision 428)
@@ -0,0 +1,60 @@
+      SUBROUTINE convflu( xflu,yflu,nbniv,convfl )
+c
+c  P. Le Van
+c
+c
+c    *******************************************************************
+c  ... calcule la (convergence horiz. * aire locale)du flux ayant pour
+c      composantes xflu et yflu ,variables extensives .  ......
+c    *******************************************************************
+c      xflu , yflu et nbniv sont des arguments d'entree pour le s-pg ..
+c      convfl                est  un argument de sortie pour le s-pg .
+c
+c     njxflu  est le nombre de lignes de latitude de xflu, 
+c     ( = jjm ou jjp1 )
+c     nbniv   est le nombre de niveaux vert. de  xflu et de yflu .
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      REAL       xflu,yflu,convfl,convpn,convps
+      INTEGER    l,ij,nbniv
+      DIMENSION  xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) ,
+     *         convfl( ip1jmp1,nbniv )
+c
+      EXTERNAL   SSUM
+      REAL       SSUM
+c
+c
+#include "comgeom.h"
+c
+      DO 5 l = 1,nbniv
+c
+      DO 2  ij = iip2, ip1jm - 1
+      convfl( ij + 1,l ) =  xflu(   ij,l ) - xflu( ij +  1,l )   +
+     *                      yflu(ij +1,l ) - yflu( ij -iim,l )
+   2  CONTINUE
+c
+c
+
+c     ....  correction pour  convfl( 1,j,l)  ......
+c     ....   convfl(1,j,l)= convfl(iip1,j,l) ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      convfl( ij,l ) = convfl( ij + iim,l )
+   3  CONTINUE
+c
+c     ......  calcul aux poles  .......
+c
+      convpn =   SSUM( iim, yflu(     1    ,l ),  1 )
+      convps = - SSUM( iim, yflu( ip1jm-iim,l ),  1 )
+      DO 4 ij = 1,iip1
+      convfl(     ij   ,l ) = convpn * aire(   ij     ) / apoln
+      convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols
+   4  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convmas.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convmas.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/convmas.F	(revision 428)
@@ -0,0 +1,62 @@
+      SUBROUTINE convmas (pbaru, pbarv, convm )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   ********************************************************************
+c   .... calcul de la convergence du flux de masse aux niveaux p ...
+c   ********************************************************************
+c
+c
+c     pbaru  et  pbarv  sont des arguments d'entree pour le s-pg  ....
+c      .....  convm      est  un argument de sortie pour le s-pg  ....
+c
+c    le calcul se fait de haut en bas, 
+c    la convergence de masse au niveau p(llm+1) est egale a 0. et
+c    n'est pas stockee dans le tableau convm .
+c
+c
+c=======================================================================
+c
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "logic.h"
+
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm(  ip1jmp1,llm )
+      INTEGER   l,ij
+
+      EXTERNAL   filtreg
+      EXTERNAL   convflu
+
+c-----------------------------------------------------------------------
+c    ....  calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ......
+
+      CALL  convflu( pbaru, pbarv, llm, convm )
+
+c-----------------------------------------------------------------------
+c   filtrage:
+c   ---------
+
+       CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 )
+
+c    integration de la convergence de masse de haut  en bas ......
+
+      DO      l      = llmm1, 1, -1
+        DO    ij     = 1, ip1jmp1
+         convm(ij,l) = convm(ij,l) + convm(ij,l+1)
+        ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coordij.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coordij.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/coordij.F	(revision 428)
@@ -0,0 +1,48 @@
+      SUBROUTINE coordij(lon,lat,ilon,jlat)
+
+c=======================================================================
+c
+c   calcul des coordonnees i et j de la maille scalaire dans
+c   laquelle se trouve le point (lon,lat) en radian
+c
+c=======================================================================
+
+      IMPLICIT NONE
+      REAL lon,lat
+      INTEGER ilon,jlat
+      INTEGER i,j
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "serre.h"
+
+      real zlon,zlat
+
+      zlon=lon
+      zlat=lat
+
+      DO i=1,iim+1
+        print*,i,' ',rlonu(i),' ',zlon 
+         IF (rlonu(i).GT.zlon) THEN
+            ilon=i
+            GOTO 10
+         ENDIF
+      ENDDO
+10    CONTINUE
+
+      j=0
+      DO j=1,jjm
+        print*,j,' ',rlatv(j),' ' ,zlat 
+         IF(rlatv(j).LT.zlat) THEN
+           
+            jlat=j
+            GOTO 20
+         ENDIF
+      ENDDO
+20    CONTINUE
+      IF(j.EQ.0) j=jjm+1
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covcont.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covcont.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covcont.F	(revision 428)
@@ -0,0 +1,40 @@
+      SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. contravariantes a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO 10 l = 1,klevel
+
+      DO 2  ij = iip2, ip1jm
+      ucont( ij,l ) = ucov( ij,l ) * unscu2( ij )
+   2  CONTINUE
+
+      DO 4 ij = 1,ip1jm
+      vcont( ij,l ) = vcov( ij,l ) * unscv2( ij )
+   4  CONTINUE
+
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covnat.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covnat.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/covnat.F	(revision 428)
@@ -0,0 +1,46 @@
+      SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  F Hourdin Phu LeVan
+c   -------
+c
+c   Objet:
+c   ------
+c
+c  *********************************************************************
+c    calcul des compos. naturelles a partir des comp.covariantes
+c  ********************************************************************
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL ucov( ip1jmp1,klevel ),  vcov( ip1jm,klevel )
+      REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel )
+      INTEGER   l,ij
+
+
+      DO l = 1,klevel
+         DO ij = 1, iip1
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = iip2, ip1jm
+            unat( ij,l ) = ucov( ij,l ) / cu(ij)
+         ENDDO
+         DO ij = ip1jm+1, ip1jmp1  
+            unat (ij,l) =0.
+         END DO
+
+         DO ij = 1,ip1jm
+            vnat( ij,l ) = vcov( ij,l ) / cv(ij)
+         ENDDO
+
+      ENDDO
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cray.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cray.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/cray.F	(revision 428)
@@ -0,0 +1,39 @@
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
+
+      function ssum(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+c
+      ssum=0.
+      ix=1
+      do 10 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+10    continue
+c
+      return
+      end
+#endif
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0.F	(revision 428)
@@ -0,0 +1,20 @@
+c
+c $Header$
+c
+      PROGRAM create_etat0
+C
+C   Programme d'appel a etat0, creation des etats initiaux
+C   
+C
+      LOGICAL interbar
+      PARAMETER ( interbar = .TRUE. )
+#include "dimensions.h"
+#include "paramet.h"
+#include "indicesol.h"
+#include "dimphy.h"
+      REAL :: masque(iip1,jjp1)
+      REAL :: pctsrf(klon, nbsrf)
+
+      CALL etat0_netcdf( interbar, masque, pctsrf )
+      STOP
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0_limit.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0_limit.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_etat0_limit.F	(revision 428)
@@ -0,0 +1,43 @@
+       PROGRAM create_etat0_limit
+c
+c
+c     Programme d'appel a etat0, creation des etats initiaux et limit_netcdf
+c   
+c
+c     interbar = .T . si appel a  interpol. barycentrique inter_barxy
+c
+c     extrap   = .T . si on fait une extrapolation de donnees , comme pour
+c       les  SST  lorsque  le fichier ne contient pas uniquement  des points 
+c     oceaniques .
+c
+c     oldice   = .T. si l'on veut garder les anciennes glaces , obtenues
+c     par  grille_m  ( grid_atob ) .
+c
+c     on cree le masque dans etat0 que l'on passe ensuite dans limit pour 
+c     garder les cohérences
+
+      LOGICAL interbar, extrap , oldice
+      PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.)
+#include "dimensions.h"
+#include "paramet.h"
+#include "indicesol.h"
+#include "dimphy.h"
+      REAL :: masque(iip1,jjp1)
+      REAL :: pctsrf(klon, nbsrf)
+
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) ' interbar = ',interbar
+      CALL etat0_netcdf ( interbar, masque, pctsrf )
+c
+      WRITE(6,1)
+      WRITE(6,*) '  *********************  '
+      WRITE(6,*) '  ***  Limit_netcdf ***  '
+      WRITE(6,*) '  *********************  '
+      WRITE(6,1)
+c
+      CALL  limit_netcdf ( interbar, extrap , oldice, masque, pctsrf )
+
+1     FORMAT(//)
+
+      STOP
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_limit.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_limit.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/create_limit.F	(revision 428)
@@ -0,0 +1,1108 @@
+c $Header$
+      PROGRAM create_limit
+      USE startvar
+      USE ioipsl
+      IMPLICIT none
+c
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 27/01/94
+C Objet  : Construction des fichiers de conditions aux limites
+C          pour le nouveau
+C          modele a partir de fichiers de climatologie. Les deux
+C          grilles doivent etre regulieres
+c
+c Modifie par z.x.li (le23mars1994)
+c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
+c                         pour lecture netcdf dans LMDZ.3.3
+c modifie par P. Braconnot pour utiliser la version sous-surfaces
+c-------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "comconst.h"
+#include "dimphy.h"
+#include "indicesol.h"
+c-----------------------------------------------------------------------
+      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)
+      logical interbar
+      parameter (interbar=.false.)
+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
+      INTEGER ibid, jbid, tbid
+      PARAMETER (ibid = 400,       ! >360 pts
+     .           jbid = 200,       ! >181 pts
+     .           tbid = 60)        ! >52 semaines
+      REAL champ(ibid*jbid)
+      REAL dlon(ibid), dlat(jbid), timecoord(tbid)
+c
+      INTEGER ibid_msk, jbid_msk
+      PARAMETER(ibid_msk=2200,jbid_msk=1100)
+      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)
+
+C Declarations pour le champ interpole 3D
+      REAL champtime(iim,jjp1,tbid)
+      REAL timeyear(tbid)
+      REAL champan(iip1,jjp1,366)
+
+C Declarations pour l'inteprolation verticale
+      REAL ax(tbid), ay(tbid)
+      REAL by
+      REAL yder(tbid)
+
+
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+CPB
+      INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
+
+      INTEGER i, j, k, l, ji
+c declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+c Diverses variables locales
+      REAL time
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+
+
+      INTEGER          longcles
+      PARAMETER      ( longcles = 20 )
+      REAL  clesphy0 ( longcles      )
+#include "serre.h"
+      INTEGER ncid,varid,ndimid(4),dimid
+      character*30 namedim
+      CHARACTER*80 :: varname
+
+c initialisations:
+!      OPEN (8,file='run.def',form='formatted')
+!      CALL defrun_new(8,.TRUE.,clesphy0)
+!      CLOSE(8)
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+      pi     = 4. * ATAN(1.)
+      rad    = 6 371 229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      dtvr    = daysec/FLOAT(day_step)
+
+c
+ccc      CALL iniconst ( non  indispensable )
+
+      CALL inigeom
+c
+c
+C Traitement du relief au sol
+c
+      write(*,*) 'Fabrication masque'
+
+      varname = 'masque'
+      masque(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0, jjm
+     ,     ,rlonu,rlatv , interbar )
+      pctsrf=0.
+      varname = 'zmasq'
+      zmasq(:) = 0.
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmasq,0.0,
+     .jjm ,rlonu,rlatv , interbar)
+      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)
+        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 
+#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 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+         print*,dimfirst,dimlast
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF 
+   
+         CALL rugosite(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint, mask)
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c      write(70,*)champtime
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+
+      PRINT 222, timeyear
+222   FORMAT(2x,' Time year ',10f6.1)
+c
+        
+      PRINT*, 'Interpolation temporelle dans l annee'
+
+
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la glace oceanique
+c
+      PRINT*, 'Traitement de la glace oceanique'
+      ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'SEA_ICE',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 
+#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 
+      print*,'variable ', namedim, jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint)
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      PRINT 222,  timeyear
+c
+      PRINT*, 'Interpolation temporelle'
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      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)
+        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) - 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
+          END DO
+        ENDIF 
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la sst
+c
+      PRINT*, 'Traitement de la sst'
+      ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'SST',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 
+#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 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+         CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint)
+
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon, 
+     .                  champan(1,1,k), phy_sst(1,k))
+      ENDDO
+c
+      WHERE(phy_sst .LT. 271.35) phy_sst = 271.35
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de l'albedo
+c
+      PRINT*, 'Traitement de l albedo'
+      ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#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 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+         CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint)
+c
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i, j, l) = champint(i, j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i, j, l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_alb(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+      DO k = 1, 360
+      DO i = 1, klon
+         phy_bil(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      PRINT*, 'Ecriture du fichier limit'
+c
+      ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
+     .                       "Fichier conditions aux limites")
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+      ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+c
+      dims(1) = ndim
+      dims(2) = ntim
+c
+      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")
+      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)")
+      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")
+      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")
+      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")
+      ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+      ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "Rugosite")
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO k = 1, 360
+c
+      debut(1) = 1
+      debut(2) = k
+      epais(1) = klon
+      epais(2) = 1
+c
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+c
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+c
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+      ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
+#endif
+c
+      ENDDO
+c
+      ierr = NF_CLOSE(nid)
+c
+      STOP
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun.F	(revision 428)
@@ -0,0 +1,195 @@
+      SUBROUTINE defrun(tapedef,creinit)
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissip.h"
+      LOGICAL creinit
+
+c   local:
+c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*8
+      INTEGER tapedef,tapeout
+      REAL clonn,clatt,alphaxx,alphayy
+c
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      tapeout=6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    idissip
+      WRITE(tapeout,9001) ch1,'idissip'
+      WRITE(tapeout,*)    idissip
+
+ccc  ....   P. Le Van , ajout  le 5/09/95 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterdis
+      WRITE(tapeout,9001) ch1,'niterdis'
+      WRITE(tapeout,*)    niterdis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetavel
+      WRITE(tapeout,9001) ch1,'tetavel'
+      WRITE(tapeout,*)    tetavel
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    physic
+      WRITE(tapeout,9001) ch1,'physic'
+      WRITE(tapeout,*)    physic
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ecritphy
+      WRITE(tapeout,9001) ch1,'ecritphy'
+      WRITE(tapeout,*)    ecritphy
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+
+      IF( creinit ) go to 100
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( clon - clonn .gt.0.001)  THEN
+        PRINT *,' La valeur de clon passee par run.def est differente de 
+     *  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( clat -clatt.gt.0.001 )  THEN
+        PRINT *,' La valeur de clat passee par run.def est differente de 
+     *  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    alphaxx
+      WRITE(tapeout,9001) ch1,'alphax'
+      WRITE(tapeout,*)    alphaxx
+
+      IF( alphax-alphaxx.gt.0.001 )  THEN
+        PRINT *,' La valeur de alphax passee par run.def est differente  
+     *  de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    alphayy
+      WRITE(tapeout,9001) ch1,'alphay'
+      WRITE(tapeout,*)    alphayy
+
+      IF( alphay-alphayy.gt.0.001 )  THEN
+        PRINT *,' La valeur de alphay passee par run.def est differente  
+     * de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      RETURN
+c
+c    
+100   CONTINUE
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    alphax
+      WRITE(tapeout,9001) ch1,'alphax'
+      WRITE(tapeout,*)    alphax
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    alphay
+      WRITE(tapeout,9001) ch1,'alphay'
+      WRITE(tapeout,*)    alphay
+
+c-----------------------------------------------------------------------
+
+      RETURN
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a8)
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun_new.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun_new.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/defrun_new.F	(revision 428)
@@ -0,0 +1,496 @@
+c
+c $Header$
+c
+      SUBROUTINE defrun_new( tapedef, etatinit, clesphy0 )
+c
+      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-----------------------------------------------------------------------
+
+      OPEN( tapedef,file ='gcm.def',status='old',form='formatted')
+
+
+      READ (tapedef,9000) ch1,ch2,ch3
+      WRITE(tapeout,9000) ch1,ch2,ch3
+
+      READ (tapedef,9001) ch1,ch4
+      WRITE(tapeout,9001) ch1,'dayref'
+      READ (tapedef,*)    dayref
+      WRITE(tapeout,9001) ch1,'dayref'
+      WRITE(tapeout,*)    dayref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    anneeref
+      WRITE(tapeout,9001) ch1,'anneeref'
+      WRITE(tapeout,*)    anneeref
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nday
+      WRITE(tapeout,9001) ch1,'nday'
+      WRITE(tapeout,*)    nday
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    day_step
+      WRITE(tapeout,9001) ch1,'day_step'
+      WRITE(tapeout,*)    day_step
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iperiod
+      WRITE(tapeout,9001) ch1,'iperiod'
+      WRITE(tapeout,*)    iperiod
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iconser
+      WRITE(tapeout,9001) ch1,'iconser'
+      WRITE(tapeout,*)    iconser
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iecri
+      WRITE(tapeout,9001) ch1,'iecri'
+      WRITE(tapeout,*)    iecri
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    periodav
+      WRITE(tapeout,9001) ch1,'periodav'
+      WRITE(tapeout,*)    periodav
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    idissip
+      WRITE(tapeout,9001) ch1,'idissip'
+      WRITE(tapeout,*)    idissip
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    lstardis
+      WRITE(tapeout,9001) ch1,'lstardis'
+      WRITE(tapeout,*)    lstardis
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergdiv
+      WRITE(tapeout,9001) ch1,'nitergdiv'
+      WRITE(tapeout,*)    nitergdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nitergrot
+      WRITE(tapeout,9001) ch1,'nitergrot'
+      WRITE(tapeout,*)    nitergrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    niterh
+      WRITE(tapeout,9001) ch1,'niterh'
+      WRITE(tapeout,*)    niterh
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagdiv
+      WRITE(tapeout,9001) ch1,'tetagdiv'
+      WRITE(tapeout,*)    tetagdiv
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetagrot
+      WRITE(tapeout,9001) ch1,'tetagrot'
+      WRITE(tapeout,*)    tetagrot
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tetatemp
+      WRITE(tapeout,9001) ch1,'tetatemp'
+      WRITE(tapeout,*)    tetatemp
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    coefdis
+      WRITE(tapeout,9001) ch1,'coefdis'
+      WRITE(tapeout,*)    coefdis
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    purmats
+      WRITE(tapeout,9001) ch1,'purmats'
+      WRITE(tapeout,*)    purmats
+
+c    ...............................................................
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    physic
+      WRITE(tapeout,9001) ch1,'physic'
+      WRITE(tapeout,*)    physic
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iphysiq
+      WRITE(tapeout,9001) ch1,'iphysiq'
+      WRITE(tapeout,*)    iphysiq
+
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ecritphy
+      WRITE(tapeout,9001) ch1,'ecritphy'
+      WRITE(tapeout,*)    ecritphy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    cycle_diurne
+      WRITE(tapeout,9001) ch1,'cycle_diurne'
+      WRITE(tapeout,*)    cycle_diurne
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    soil_model
+      WRITE(tapeout,9001) ch1,'soil_model'
+      WRITE(tapeout,*)    soil_model
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    new_oliq
+      WRITE(tapeout,9001) ch1,'new_oliq'
+      WRITE(tapeout,*)    new_oliq
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orodr
+      WRITE(tapeout,9001) ch1,'ok_orodr'
+      WRITE(tapeout,*)    ok_orodr
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_orolf
+      WRITE(tapeout,9001) ch1,'ok_orolf'
+      WRITE(tapeout,*)    ok_orolf
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ok_limitvrai
+      WRITE(tapeout,9001) ch1,'ok_limitvrai'
+      WRITE(tapeout,*)    ok_limitvrai
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    nbapp_rad
+      WRITE(tapeout,9001) ch1,'nbapp_rad'
+      WRITE(tapeout,*)    nbapp_rad
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    iflag_con
+      WRITE(tapeout,9001) ch1,'iflag_con'
+      WRITE(tapeout,*)    iflag_con
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+                          clesphy0(1) = 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
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clonn
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clonn
+      IF( ABS(clon - clonn).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clatt
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clatt
+
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe
+     *rente de  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismxx
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismyy
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+       WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est
+     , differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+c    alphax et alphay sont les anciennes formulat. des grossissements
+c
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    fxyhypbb
+
+      IF( .NOT.fxyhypb )  THEN
+           IF( fxyhypbb )     THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F'
+     *,      '                   alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+      ELSE
+           IF( .NOT.fxyhypbb )   THEN
+            WRITE(tapeout,*) ' ********  PBS DANS  DEFRUN  ******** '
+            WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t'
+     *,      '                   alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+      ENDIF
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomyy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauxx
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    tauxx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauyy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauyy
+
+      IF( fxyhypb )  THEN
+
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif
+     *ferente de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de taux passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        WRITE(6,*)' La valeur de tauy passee par run.def est differente
+     *  de celle lue sur le fichier  start '
+        CALL ABORT
+       ENDIF
+
+      ENDIF
+      
+cc
+      IF( .NOT.fxyhypb  )  THEN
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinuss
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinuss
+
+
+        IF( .NOT.ysinus )  THEN
+           IF( ysinuss )     THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est F',
+     *       ' alors  qu il est  T  sur  run.def  ***'
+              STOP
+           ENDIF
+        ELSE
+           IF( .NOT.ysinuss )   THEN
+              WRITE(6,*) ' ********  PBS DANS  DEFRUN  ******** '
+              WRITE(tapeout,*)'** ysinus lu sur le fichier start est T',
+     *       ' alors  qu il est  F  sur  run.def  ***'
+              STOP
+           ENDIF
+        ENDIF
+      ENDIF
+c
+      WRITE(6,*) ' alphax alphay defrun ',alphax,alphay
+
+      CLOSE(tapedef)
+
+      RETURN
+c   ...............................................
+c
+100   CONTINUE
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clon
+      WRITE(tapeout,9001) ch1,'clon'
+      WRITE(tapeout,*)    clon
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    clat
+      WRITE(tapeout,9001) ch1,'clat'
+      WRITE(tapeout,*)    clat
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    grossismx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    grossismy
+
+      IF( grossismx.LT.1. )  THEN
+        WRITE(tapeout,*) '***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+      IF( grossismy.LT.1. )  THEN
+        WRITE(tapeout,*) ' ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypb
+      WRITE(tapeout,9001) ch1,'fxyhypb'
+      WRITE(tapeout,*)    fxyhypb
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomx
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    dzoomy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    taux
+      WRITE(tapeout,9001) ch1,'taux'
+      WRITE(tapeout,*)    taux
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    tauy
+      WRITE(tapeout,9001) ch1,'tauy'
+      WRITE(tapeout,*)    tauy
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+      WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      CLOSE(tapedef)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/description.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/description.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/description.h	(revision 428)
@@ -0,0 +1,2 @@
+      character *120 descript
+      common /titre/descript
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dh1.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dh1.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dh1.F	(revision 428)
@@ -0,0 +1,67 @@
+      SUBROUTINE dh1 ( h, pbaru, pbarv, dh)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq de dhdq1 pour construire dh1)
+c
+c   ********************************************************************
+c   .... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c     h,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dh 	       sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL h( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dh( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+      EXTERNAL     convflu
+      EXTERNAL     filtreg
+c
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm - 1
+      hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( h(ij,l) + h(ij+1,l) )
+   1  CONTINUE
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+CDIR$ IVDEP
+      DO 2 ij = iip1+ iip1, ip1jm, iip1
+      hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      hbyv( ij, l ) = pbarv(ij, l) * 0.5 * ( h(ij, l) + h(ij +iip1, l) )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+        CALL  convflu ( hbxu, hbyv, llm, dh )
+
+
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+
+      CALL filtreg( dh, jjp1, llm, 2,2, .true., 1)
+
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagadv.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagadv.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagadv.F	(revision 428)
@@ -0,0 +1,77 @@
+      subroutine diagadv(q,masse,descript)
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      real q(iip1,jjp1,llm),masse(iip1,jjp1,llm)
+      integer i,j,l
+      character*10 descript
+      real sss,smas,smin,smax
+ 
+      external ismin,ismax
+      integer ismin,ismax
+ 
+      sss=0.
+      smas=0.
+      smin=1.e33
+      smax=-1.e33
+      do l=1,llm
+        do j=1,jjp1
+           do i=1,iim
+              sss=sss+masse(i,j,l)*q(i,j,l)
+              smas=smas+masse(i,j,l)
+              smin=min(smin,q(i,j,l))
+              smax=max(smax,q(i,j,l))
+           enddo
+        enddo
+      enddo
+
+      write(*,1000) descript,smin,smax,sss/smas,sss
+ 
+      return
+1000  format(a10,'   MIN:',e15.4,'   MAX:',e15.4,'   MOY:',e15.4
+     s   ,'   TOT:',e15.4)
+      end
+
+      FUNCTION ismin(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,i,incx,ismin,ix
+      real sx((n-1)*incx+1),sxmin
+c
+      ix=1
+      ismin=1
+      sxmin=sx(1)
+      DO i=1,n-1
+         ix=ix+incx
+         if(sx(ix).lt.sxmin) then
+             sxmin=sx(ix)
+             ismin=i+1
+         endif
+      ENDDO
+c
+      return
+      end
+C
+      function ismax(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      INTEGER n,i,incx,ismax,ix
+      real sx((n-1)*incx+1),sxmax
+c
+      ix=1
+      ismax=1
+      sxmax=sx(1)
+      do 10 i=1,n-1
+       ix=ix+incx
+       if(sx(ix).gt.sxmax) then
+         sxmax=sx(ix)
+         ismax=i+1
+       endif
+10    continue
+c
+      return
+      end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagedyn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagedyn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diagedyn.F	(revision 428)
@@ -0,0 +1,308 @@
+
+C======================================================================
+      SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime
+     e  , ucov    , vcov , ps, p ,pk , teta , q, ql,aire
+     s  , d_h_vcol , d_qt, d_qw, d_ql, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la dynamique.
+C
+C
+c======================================================================
+C Arguments: 
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+C uconv, vconv-input-R- vents covariants (m/s)
+C ps-------input-R- Surface pressure (Pa)
+C p--------input-R- pressure at the interfaces
+C pk-------input-R- pk= (p/Pref)**kappa
+c teta-----input-R- potential temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c aire-----input-R- mesh surafce (m2)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "paramet.h"
+#include "../phylmd/YOMCST.h"
+#include "../phylmd/YOETHF.h"
+C
+      INTEGER imjmp1
+      PARAMETER( imjmp1=iim*jjp1)
+c     Input variables
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )  ! pression aux interfac.des couches
+      REAL pk (ip1jmp1,llmp1  )  ! = (p/Pref)**kappa
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm)               ! champs eau vapeur
+      REAL ql(ip1jmp1,llm)               ! champs eau liquide
+      REAL aire(ip1jmp1)               ! aire des mailles
+
+
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL ecin(ip1jmp1,llm)
+
+      REAL zaire(imjmp1)
+      REAL zps(imjmp1)
+      REAL zairm(imjmp1,llm)
+      REAL zecin(imjmp1,llm)
+      REAL zpaprs(imjmp1,llm)
+      REAL zpk(imjmp1,llm)
+      REAL zt(imjmp1,llm)
+      REAL zh(imjmp1,llm)
+      REAL zqw(imjmp1,llm)
+      REAL zql(imjmp1,llm)
+      REAL zqs(imjmp1,llm)
+
+      REAL  zqw_col(imjmp1)
+      REAL  zql_col(imjmp1)
+      REAL  zqs_col(imjmp1)
+      REAL  zec_col(imjmp1)
+      REAL  zh_dair_col(imjmp1)
+      REAL  zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k, jj, ij , l ,ip1jjm1
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+
+c======================================================================
+C     Compute Kinetic enrgy
+      CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+      CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+      CALL massdair( p, masse )
+c======================================================================
+C
+C
+C     On ne garde les donnees que dans les colonnes i=1,iim
+      DO jj = 1,jjp1
+        ip1jjm1=iip1*(jj-1)
+        DO ij =  1,iim
+          i=iim*(jj-1)+ij
+          zaire(i)=aire(ij+ip1jjm1)
+          zps(i)=ps(ij+ip1jjm1)
+        ENDDO 
+      ENDDO 
+C 3D arrays
+      DO l  =  1, llm
+        DO jj = 1,jjp1
+          ip1jjm1=iip1*(jj-1)
+          DO ij =  1,iim
+            i=iim*(jj-1)+ij
+            zairm(i,l) = masse(ij+ip1jjm1,l)
+            zecin(i,l) = ecin(ij+ip1jjm1,l)
+            zpaprs(i,l) = p(ij+ip1jjm1,l)
+            zpk(i,l) = pk(ij+ip1jjm1,l)
+            zh(i,l) = teta(ij+ip1jjm1,l)
+            zqw(i,l) = q(ij+ip1jjm1,l)
+            zql(i,l) = ql(ij+ip1jjm1,l)
+            zqs(i,l) = 0.
+          ENDDO 
+        ENDDO 
+      ENDDO 
+C
+C     Reset variables
+      DO i = 1, imjmp1
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, llm
+        DO i = 1, imjmp1
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +zecin(i,k)*zairm(i,k)
+C         Air enthalpy
+          zt(i,k)= zh(i,k) * zpk(i,k) / RCPD
+          zh_dair_col(i) = zh_dair_col(i)
+     $        + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLVTT*zql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) 
+     $        - RLSTT*zqs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,imjmp1
+        qw_tot = qw_tot + zqw_col(i)
+        ql_tot = ql_tot + zql_col(i)
+        qs_tot = qs_tot + zqs_col(i)
+        ec_tot = ec_tot + zec_col(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)
+        airetot=airetot+zaire(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+C        WRITE(6,9003) tit,pas(idiag), ec_tot
+ 9003   format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6))
+        WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec
+ 9004   format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dissip.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dissip.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dissip.F	(revision 428)
@@ -0,0 +1,142 @@
+      SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh )
+c
+      IMPLICIT NONE
+
+
+c ..  Avec nouveaux operateurs star :  gradiv2 , divgrad2, nxgraro2  ...
+c                                 (  10/01/98  )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   Dissipation horizontale
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comdissnew.h"
+#include "comdissipn.h"
+
+c   Arguments:
+c   ----------
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL  p( ip1jmp1,llmp1 )
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm)
+      REAL grx(ip1jmp1,llm),gry(ip1jm,llm)
+      REAL te1dt(llm),te2dt(llm),te3dt(llm)
+      REAL deltapres(ip1jmp1,llm)
+
+      INTEGER l,ij
+
+      REAL  SSUM
+      EXTERNAL  gradiv ,nXgrarot,divgrad,initial0
+      EXTERNAL  gradiv2,nXgraro2,divgrad2,SSUM
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      DO l=1,llm
+         te1dt(l) = tetaudiv(l) * dtdiss
+         te2dt(l) = tetaurot(l) * dtdiss
+         te3dt(l) = tetah(l)    * dtdiss
+      ENDDO
+      CALL initial0( ijp1llm, du )
+      CALL initial0( ijmllm , dv )
+      CALL initial0( ijp1llm, dh )
+
+c-----------------------------------------------------------------------
+c   Calcul de la dissipation:
+c   -------------------------
+
+c   Calcul de la partie   grad  ( div ) :
+c   -------------------------------------
+
+
+      IF(lstardis) THEN
+         CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ELSE
+         CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy )
+      ENDIF
+
+      DO l=1,llm
+
+         DO ij = 1, iip1
+            gdx(     ij ,l) = 0.
+            gdx(ij+ip1jm,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l)
+         ENDDO
+
+       ENDDO
+
+c   calcul de la partie   n X grad ( rot ):
+c   ---------------------------------------
+
+      IF(lstardis) THEN
+         CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry )
+      ELSE
+         CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry )
+      ENDIF
+
+
+      DO l=1,llm
+         DO ij = 1, iip1
+            grx(ij,l) = 0.
+         ENDDO
+
+         DO ij = iip2,ip1jm
+            du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l)
+         ENDDO
+         DO ij =  1, ip1jm
+            dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l)
+         ENDDO
+      ENDDO
+
+c   calcul de la partie   div ( grad ):
+c   -----------------------------------
+
+        
+      IF(lstardis) THEN
+
+       DO l = 1, llm
+          DO ij = 1, ip1jmp1
+            deltapres(ij,l) = AMAX1( 0.,  p(ij,l) - p(ij,l+1) )
+          ENDDO
+       ENDDO
+
+         CALL divgrad2( llm,teta, deltapres  ,niterh, gdx )
+      ELSE
+         CALL divgrad ( llm,teta, niterh, gdx        )
+      ENDIF
+
+      DO l = 1,llm
+         DO ij = 1,ip1jmp1
+            dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l )
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert.F	(revision 428)
@@ -0,0 +1,147 @@
+      SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL pa,preff
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) deltaz
+      READ(99,*) h
+      READ(99,*) beta
+      READ(99,*) gama
+      READ(99,*) delta
+      READ(99,*) np
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+c
+
+       DO 1  l = 1, llm
+       dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*
+     $          ( (tanh(gama*l)/tanh(gama*llm))**np +
+     $            (1.-l/FLOAT(llm))*delta )
+   1   CONTINUE
+
+       sig(1)=1.
+       DO 101 l=1,llm-1
+          sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
+101    CONTINUE
+       sig(llm+1)=0.
+
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      PRINT*,'WARNING!!! Ancienne discretisation verticale'
+
+      h=7.
+      snorm  = 0.
+      DO l = 1, llm
+         x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
+         dsig(l) = 1.0 + 7.0 * SIN(x)**2
+         snorm = snorm + dsig(l)
+      ENDDO
+      snorm = 1./snorm
+      DO l = 1, llm
+         dsig(l) = dsig(l)*snorm
+      ENDDO
+      sig(llm+1) = 0.
+      DO l = llm, 1, -1
+         sig(l) = sig(l+1) + dsig(l)
+      ENDDO
+
+      ENDIF
+
+
+      DO l=1,llm
+        nivsigs(l) = FLOAT(l)
+      ENDDO
+
+      DO l=1,llmp1
+        nivsig(l)= FLOAT(l)
+      ENDDO
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par lectba  .....
+c
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+cc
+ccc    ap(l) = 0.
+ccc    bp(l) = sig(l)
+
+      bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+      ap(l) = pa * ( sig(l) - bp(l) )
+c
+      ENDDO
+      ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      PRINT *,' BP '
+      PRINT *,  bp
+      PRINT *,' AP '
+      PRINT *,  ap
+
+      DO l = 1, llm
+       dpres(l) = bp(l) - bp(l+1)
+       presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+      ENDDO
+
+      PRINT *,' PRESNIVS '
+      PRINT *,presnivs
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/disvert0.F	(revision 428)
@@ -0,0 +1,148 @@
+      SUBROUTINE disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+
+c    Auteur :  P. Le Van .
+c
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+c
+c=======================================================================
+c
+c
+c    s = sigma ** kappa   :  coordonnee  verticale
+c    dsig(l)            : epaisseur de la couche l ds la coord.  s
+c    sig(l)             : sigma a l'interface des couches l et l-1
+c    ds(l)              : distance entre les couches l et l-1 en coord.s
+c
+c=======================================================================
+c
+      REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1)
+      REAL pa,preff,presnivs(llm)
+c
+c   declarations:
+c   -------------
+c
+      REAL sig(llm+1),dsig(llm)
+c
+      INTEGER l
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h
+      INTEGER np,ierr
+      REAL pi,x
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      OPEN(99,file='sigma.def',status='old',form='formatted',
+     s   iostat=ierr)
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr.eq.0) THEN
+
+      READ(99,*) deltaz
+      READ(99,*) h
+      READ(99,*) beta
+      READ(99,*) gama
+      READ(99,*) delta
+      READ(99,*) np
+      CLOSE(99)
+      alpha=deltaz/(llm*h)
+c
+
+       DO 1  l = 1, llm
+       dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*
+     $          ( (tanh(gama*l)/tanh(gama*llm))**np +
+     $            (1.-l/FLOAT(llm))*delta )
+   1   CONTINUE
+
+       sig(1)=1.
+       DO 101 l=1,llm-1
+          sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
+101    CONTINUE
+       sig(llm+1)=0.
+
+       DO 2  l = 1, llm
+       dsig(l) = sig(l)-sig(l+1)
+   2   CONTINUE
+c
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      PRINT*,'WARNING!!! Ancienne discretisation verticale'
+
+      h=7.
+      snorm  = 0.
+      DO l = 1, llm
+         x = 2.*asin(1.) * (FLOAT(l)-0.5) / float(llm+1)
+         dsig(l) = 1.0 + 7.0 * SIN(x)**2
+         snorm = snorm + dsig(l)
+      ENDDO
+      snorm = 1./snorm
+      DO l = 1, llm
+         dsig(l) = dsig(l)*snorm
+      ENDDO
+      sig(llm+1) = 0.
+      DO l = llm, 1, -1
+         sig(l) = sig(l+1) + dsig(l)
+      ENDDO
+
+      ENDIF
+
+
+      DO l=1,llm
+        nivsigs(l) = FLOAT(l)
+      ENDDO
+
+      DO l=1,llmp1
+        nivsig(l)= FLOAT(l)
+      ENDDO
+
+c ....  Calculs  de ap(l) et de bp(l)  ....
+c .........................................
+c
+      pa        =  50 000.
+      preff     = 101 325.
+c                     .... Pascals ....
+
+      bp(llmp1) =   0.
+
+      DO l = 1, llm
+c
+ccc      ap(l) = 0.
+ccc      bp(l) = sig(l)
+
+       bp(l) = EXP( 1. -1./( sig(l)*sig(l)) )
+       ap(l) = pa * ( sig(l) - bp(l) )
+
+      ENDDO
+       ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) )
+
+      PRINT *,' BP '
+      PRINT *, bp
+      PRINT *,' AP '
+      PRINT *, ap
+
+      DO l = 1, llm
+       dpres(l) = bp(l) - bp(l+1)
+       presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff )
+      ENDDO
+
+      PRINT *,' PRESNIVS '
+      PRINT *,presnivs
+c-----------------------------------------------------------------------
+c
+
+c-----------------------------------------------------------------------
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg.F	(revision 428)
@@ -0,0 +1,83 @@
+      SUBROUTINE diverg(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+ccc        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg_gam.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg_gam.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/diverg_gam.F	(revision 428)
@@ -0,0 +1,78 @@
+      SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam ,
+     *                       unsapolnga,unsapolsga,  x, y,  div )
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1)
+      REAL unsapolnga,unsapolsga
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+      INTEGER   l,ij
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     = (  
+     *  cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) +
+     *  cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* 
+     *         unsairegam( ij+1 )
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvscvgam(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga
+        sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn 
+         div( ij + ip1jm, l ) =   sumyps 
+        ENDDO
+  10  CONTINUE
+c
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergf.F	(revision 428)
@@ -0,0 +1,83 @@
+      SUBROUTINE divergf(klevel,x,y,div)
+c
+c     P. Le Van
+c
+c  *********************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. 
+c     x et y...
+c              x et y  etant des composantes covariantes   ...
+c  *********************************************************************
+      IMPLICIT NONE
+c
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   ---------------------------------------------------------------------
+c
+c    ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/  .
+c
+c   ---------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c    ..........          variables en arguments    ...................
+c
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER   l,ij
+c
+c    ...............     variables  locales   .........................
+
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+c    ...................................................................
+c
+      EXTERNAL  SSUM
+      REAL      SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+        DO  ij = iip2, ip1jm - 1
+         div( ij + 1, l )     =  
+     *   cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) +
+     *   cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) 
+        ENDDO
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+        DO  ij = iip2,ip1jm,iip1
+         div( ij,l ) = div( ij + iim,l )
+        ENDDO
+c
+c     ....  calcul  aux poles  .....
+c
+        DO  ij  = 1,iim
+         aiy1(ij) =    cuvsurcv(    ij       ) * y(     ij     , l )
+         aiy2(ij) =    cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l )
+        ENDDO
+        sumypn = SSUM ( iim,aiy1,1 ) / apoln
+        sumyps = SSUM ( iim,aiy2,1 ) / apols
+c
+        DO  ij = 1,iip1
+         div(     ij    , l ) = - sumypn
+         div( ij + ip1jm, l ) =   sumyps
+        ENDDO
+  10  CONTINUE
+c
+
+        CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 )
+      
+c
+        DO l = 1, klevel
+           DO ij = iip2,ip1jm
+            div(ij,l) = div(ij,l) * unsaire(ij) 
+          ENDDO
+        ENDDO
+c
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergst.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergst.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divergst.F	(revision 428)
@@ -0,0 +1,60 @@
+      SUBROUTINE divergst(klevel,x,y,div)
+      IMPLICIT NONE
+c
+c     P. Le Van
+c
+c  ******************************************************************
+c  ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y...
+c           x et y  etant des composantes contravariantes   ...
+c  ****************************************************************
+c      x  et  y  sont des arguments  d'entree pour le s-prog
+c        div      est  un argument  de sortie pour le s-prog
+c
+c
+c   -------------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel )
+      INTEGER ij,l,i
+      REAL aiy1( iip1 ) , aiy2( iip1 )
+      REAL sumypn,sumyps
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1 ij = iip2, ip1jm - 1
+      div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l)
+   1  CONTINUE
+c
+c     ....  correction pour  div( 1,j,l)  ......
+c     ....   div(1,j,l)= div(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 3 ij = iip2,ip1jm,iip1
+      div( ij,l ) = div( ij + iim,l )
+   3  CONTINUE
+c
+c     ....  calcul  aux poles  .....
+c
+c
+      DO 5 i  = 1,iim
+      aiy1(i)= y(i,l)
+      aiy2(i)= y(i+ip1jmi1,l)
+   5  CONTINUE
+      sumypn = SSUM ( iim,aiy1,1 )
+      sumyps = SSUM ( iim,aiy2,1 )
+      DO 7 i = 1,iip1
+      div(     i    , l ) = - sumypn/iim
+      div( i + ip1jm, l ) =   sumyps/iim
+   7  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad.F	(revision 428)
@@ -0,0 +1,55 @@
+      SUBROUTINE divgrad (klevel,h, lh, divgra )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c  Auteur :   P. Le Van
+c  ----------
+c
+c                              lh
+c      calcul de  (div( grad ))   de h  .....
+c      h  et lh  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+
+      INTEGER  l,ij,iter,lh
+c
+      EXTERNAL  filtreg
+      EXTERNAL  SCOPY, grad, covcont, diverg
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+c
+      DO 10 iter = 1,lh
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1  )
+
+      CALL    grad (klevel,divgra, ghx  , ghy          )
+      CALL  diverg (klevel,  ghx , ghy  , divgra       )
+
+      CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1)
+
+      DO 5 l = 1,klevel
+      DO 4  ij = 1, ip1jmp1
+      divgra( ij,l ) = - cdivh * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/divgrad2.F	(revision 428)
@@ -0,0 +1,78 @@
+      SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra )
+c
+c     P. Le Van
+c
+c   ***************************************************************
+c
+c     .....   calcul de  (div( grad ))   de (  pext * h ) .....
+c   ****************************************************************
+c   h ,klevel,lh et pext  sont des arguments  d'entree pour le s-prg
+c         divgra     est  un argument  de sortie pour le s-prg
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comdissipn.h"
+
+c    .......    variables en arguments   .......
+c
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel )
+      REAL divgra( ip1jmp1,klevel)
+c
+c    .......    variables  locales    ..........
+c
+      REAL     signe, nudivgrs, sqrtps( ip1jmp1,llm )
+      INTEGER  l,ij,iter,lh
+c    ...................................................................
+
+      EXTERNAL  filtreg
+      EXTERNAL  SCOPY,  laplacien_gam
+c
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+      CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 )
+
+c
+      CALL laplacien( klevel, divgra, divgra )
+     
+      DO l = 1, klevel
+       DO ij = 1, ip1jmp1
+        sqrtps( ij,l ) = SQRT( deltapres(ij,l) )
+       ENDDO
+      ENDDO
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+         divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+   
+c    ........    Iteration de l'operateur  laplacien_gam    ........
+c
+      DO  iter = 1, lh - 2
+       CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2,
+     *                     unsapolnga2, unsapolsga2,  divgra, divgra )
+      ENDDO
+c
+c    ...............................................................
+ 
+      DO l = 1, klevel
+        DO ij = 1, ip1jmp1
+          divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l)
+        ENDDO
+      ENDDO
+c
+      CALL laplacien ( klevel, divgra, divgra )
+c
+      DO l  = 1,klevel
+      DO ij = 1,ip1jmp1
+      divgra(ij,l) =  nudivgrs * divgra(ij,l) / deltapres(ij,l)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dteta1.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dteta1.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dteta1.F	(revision 428)
@@ -0,0 +1,67 @@
+      SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c Modif F.Forget 03/94 (on retire q et dq  pour construire dteta1)
+c
+c   ********************************************************************
+c   ... calcul du terme de convergence horizontale du flux d'enthalpie
+c        potentielle   ......
+c   ********************************************************************
+c  .. teta,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dteta 	          sont des arguments de sortie pour le s-pg ....
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+
+      REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL dteta( ip1jmp1,llm )
+      INTEGER   l,ij
+
+      REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm )
+
+      EXTERNAL     convflu
+      EXTERNAL     filtreg
+c
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm - 1
+      hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) )
+   1  CONTINUE
+
+c    .... correction pour  hbxu(iip1,j,l)  .....
+c    ....   hbxu(iip1,j,l)= hbxu(1,j,l) ....
+
+CDIR$ IVDEP
+      DO 2 ij = iip1+ iip1, ip1jm, iip1
+      hbxu( ij, l ) = hbxu( ij - iim, l )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+        CALL  convflu ( hbxu, hbyv, llm, dteta )
+
+
+c    stockage dans  dh de la convergence horizont. filtree' du  flux
+c                  ....                           ...........
+c           d'enthalpie potentielle .
+
+      CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1)
+
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv1.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv1.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv1.F	(revision 428)
@@ -0,0 +1,50 @@
+      SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv )
+      IMPLICIT NONE
+c
+c-----------------------------------------------------------------------
+c
+c   Auteur:   P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c   calcul du terme de  rotation
+c   ce terme est ajoute a  d(ucov)/dt et a d(vcov)/dt  ..
+c   vorpot, pbaru et pbarv sont des arguments d'entree  pour le s-pg ..
+c   du  et dv              sont des arguments de sortie pour le s-pg ..
+c
+c-----------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) ,
+     *     pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 10 l = 1,llm
+c
+      DO 2  ij = iip2, ip1jm - 1
+      du( ij,l ) = 0.125 *(  vorpot(ij-iip1, l) + vorpot( ij, l)  ) *
+     *                    (   pbarv(ij-iip1, l) + pbarv(ij-iim,  l) +
+     *                        pbarv(   ij  , l) + pbarv(ij+ 1 ,  l)   )
+   2  CONTINUE
+c
+      DO 3 ij = 1, ip1jm - 1
+      dv( ij+1,l ) = - 0.125 *(  vorpot(ij, l)  + vorpot(ij+1, l)  ) *
+     *                        (   pbaru(ij, l)  +  pbaru(ij+1   , l) +
+     *                       pbaru(ij+iip1, l)  +  pbaru(ij+iip2, l)  )
+   3  CONTINUE
+c
+c    .... correction  pour  dv( 1,j,l )  .....
+c    ....   dv(1,j,l)= dv(iip1,j,l) ....
+c
+CDIR$ IVDEP
+      DO 4 ij = 1, ip1jm, iip1
+      dv( ij,l ) = dv( ij + iim, l )
+   4  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dudv2.F	(revision 428)
@@ -0,0 +1,60 @@
+      SUBROUTINE dudv2 ( teta, pkf, bern, du, dv  )
+
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   *****************************************************************
+c   ..... calcul du terme de pression (gradient de p/densite )   et
+c          du terme de ( -gradient de la fonction de Bernouilli ) ...
+c   *****************************************************************
+c          Ces termes sont ajoutes a  d(ucov)/dt et a d(vcov)/dt  ..
+c
+c
+c    teta , pkf, bern  sont des arguments d'entree  pour le s-pg  ....
+c    du et dv          sont des arguments de sortie pour le s-pg  ....
+c
+c=======================================================================
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ),
+     *         du( ip1jmp1,llm ),  dv( ip1jm,llm )
+      INTEGER  l,ij
+c
+c
+      DO 5 l = 1,llm
+c
+      DO 2  ij  = iip2, ip1jm - 1
+       du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) *
+     * ( pkf( ij,l ) - pkf(ij+1,l) )  + bern(ij,l) - bern(ij+1,l)
+   2  CONTINUE
+c
+c
+c    .....  correction  pour du(iip1,j,l),  j=2,jjm   ......
+c    ...          du(iip1,j,l) = du(1,j,l)                 ...
+c
+CDIR$ IVDEP
+      DO 3 ij = iip1+ iip1, ip1jm, iip1
+      du( ij,l ) = du( ij - iim,l )
+   3  CONTINUE
+c
+c
+      DO 4 ij  = 1,ip1jm
+      dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) *
+     *                             ( pkf(ij+iip1,l) - pkf(  ij,l  ) )
+     *                           +   bern( ij+iip1,l ) - bern( ij  ,l )
+   4  CONTINUE
+c
+   5  CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dump2d.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dump2d.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dump2d.F	(revision 428)
@@ -0,0 +1,43 @@
+      SUBROUTINE dump2d(im,jm,z,nom_z)
+      IMPLICIT NONE
+      INTEGER im,jm
+      REAL z(im,jm)
+      CHARACTER*80 nom_z
+
+      INTEGER i,j,imin,illm,jmin,jllm
+      REAL zmin,zllm
+
+      PRINT*,nom_z
+
+      zmin=z(1,1)
+      zllm=z(1,1)
+      imin=1
+      illm=1
+      jmin=1
+      jllm=1
+
+      DO j=1,jm
+         DO i=1,im
+            IF(z(i,j).GT.zllm) THEN
+               illm=i
+               jllm=j
+               zllm=z(i,j)
+            ENDIF
+            IF(z(i,j).LT.zmin) THEN
+               imin=i
+               jmin=j
+               zmin=z(i,j)
+            ENDIF
+         ENDDO
+      ENDDO
+
+      PRINT*,'MIN: ',zmin
+      PRINT*,'MAX: ',zllm
+
+      IF(zllm.GT.zmin) THEN
+      DO j=1,jm
+      WRITE(*,'(72i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im)
+      ENDDO
+      ENDIF
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynetat0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynetat0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynetat0.F	(revision 428)
@@ -0,0 +1,389 @@
+c
+c $Header$
+c
+      SUBROUTINE dynetat0(fichnom,nq,vcov,ucov,
+     .                    teta,q,masse,ps,phis,time)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van / L.Fairhead
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Lecture de l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "logic.h"
+
+c   Arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      INTEGER nq
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid
+      CHARACTER  str3*3
+
+c-----------------------------------------------------------------------
+
+c  Ouverture NetCDF du fichier etat initial
+
+      ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier start.nc'
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      day_ref    = tab_cntrl(4)
+      annee_ref  = tab_cntrl(5)
+      rad        = tab_cntrl(6)
+      omeg       = tab_cntrl(7)
+      g          = tab_cntrl(8)
+      cpp        = tab_cntrl(9)
+      kappa      = tab_cntrl(10)
+      daysec     = tab_cntrl(11)
+      dtvr       = tab_cntrl(12)
+      etot0      = tab_cntrl(13)
+      ptot0      = tab_cntrl(14)
+      ztot0      = tab_cntrl(15)
+      stot0      = tab_cntrl(16)
+      ang0       = tab_cntrl(17)
+      pa         = tab_cntrl(18)
+      preff      = tab_cntrl(19)
+c
+      clon       = tab_cntrl(20)
+      clat       = tab_cntrl(21)
+      grossismx  = tab_cntrl(22)
+      grossismy  = tab_cntrl(23)
+c
+      IF ( tab_cntrl(24).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+        dzoomx   = tab_cntrl(25)
+        dzoomy   = tab_cntrl(26)
+        taux     = tab_cntrl(28)
+        tauy     = tab_cntrl(29)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. 
+      ENDIF
+
+      day_ini = tab_cntrl(30)
+      itau_dyn = tab_cntrl(31)
+c   .................................................................
+c
+c
+      PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa
+
+      IF(   im.ne.iim           )  THEN
+          PRINT 1,im,iim
+          STOP
+      ELSE  IF( jm.ne.jjm       )  THEN
+          PRINT 2,jm,jjm
+          STOP
+      ELSE  IF( lllm.ne.llm     )  THEN
+          PRINT 3,lllm,llm
+          STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cu)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cu>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "cv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <cv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <aire> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aire)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <aire>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phis)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <temps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, time)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee <temps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ucov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ucov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ucov>"
+         CALL abort
+      ENDIF
+ 
+      ierr = NF_INQ_VARID (nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <vcov> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, vcov)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <vcov>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <teta> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, teta)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <teta>"
+         CALL abort
+      ENDIF
+
+
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+        str3(1:1)='q'
+        IF(iq.GT.99) THEN
+           PRINT*, "Trop de traceurs"
+           CALL abort
+        ENDIF
+        WRITE(str3(2:3),'(i2.2)') iq
+        ierr =  NF_INQ_VARID (nid, str3, nvarid)
+        IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: Le champ <"//str3//"> est absent"
+           PRINT*, "          Il est donc initialise a zero"
+           CALL initial0(ijp1llm,q(1,1,iq))
+        ELSE
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq))
+#else
+          ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq))
+#endif
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "dynetat0: Lecture echouee pour "//str3
+             CALL abort
+          ENDIF
+        ENDIF
+      ENDDO
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <masse> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, masse)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <masse>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, ps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "dynetat0: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_CLOSE(nid)
+
+       day_ini=day_ini+INT(time)
+       time=time-INT(time)
+
+  1   FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem
+     *arrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema
+     *rrage est differente de la valeur  dtinteg =',i4//)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynhist.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynhist.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynhist.F	(revision 428)
@@ -0,0 +1,578 @@
+      SUBROUTINE dynhist0(fichnom,idayref,anneeref,phis,nq)
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER*4 idayref,anneeref
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+      INTEGER nq
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      CHARACTER str3*3
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = FLOAT(iim)
+       tab_cntrl(2)  = FLOAT(jjm)
+       tab_cntrl(3)  = FLOAT(llm)
+       tab_cntrl(4)  = FLOAT(idayref)
+       tab_cntrl(5)  = FLOAT(anneeref)
+       tab_cntrl(6)  = rad
+       tab_cntrl(7)  = omeg
+       tab_cntrl(8)  = g
+       tab_cntrl(9)  = cpp
+       tab_cntrl(10) = kappa
+       tab_cntrl(11) = daysec
+       tab_cntrl(12) = dtvr
+       tab_cntrl(13) = etot0
+       tab_cntrl(14) = ptot0
+       tab_cntrl(15) = ztot0
+       tab_cntrl(16) = stot0
+       tab_cntrl(17) = ang0
+       tab_cntrl(18) = pa
+       tab_cntrl(19) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(24) = 1.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+      ELSE
+       tab_cntrl(24) = 0.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1. 
+      ENDIF
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#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
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      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")
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      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")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      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")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      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")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF (iq.GT.99) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ELSE
+         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)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      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 ?")
+c
+      dims3(1) = idim_rlonv
+      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")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'iim,jjm,llm,idayref',iim,jjm,llm,idayref
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      RETURN
+      END
+      SUBROUTINE dynhist1(fichnom,time,
+     .                     vcov,ucov,teta,q,nq,masse,ps)
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+
+      INTEGER nq, l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nq)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid
+      INTEGER ierr
+      INTEGER iq
+      CHARACTER str3*3
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable temps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF (iq.GT.99) THEN
+          PRINT*, "Trop de traceurs"
+          CALL abort
+      ELSE
+          str3(1:1)='q'
+          WRITE(str3(2:3),'(i2.2)') iq
+          ierr = NF_INQ_VARID(nid, str3, nvarid)
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "Variable "//str3//" n est pas definie"
+             CALL abort
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+          ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynredem.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynredem.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/dynredem.F	(revision 428)
@@ -0,0 +1,527 @@
+c $Header$
+c
+      SUBROUTINE dynredem0(fichnom,iday_end,phis,nq)
+      USE IOIPSL
+      IMPLICIT NONE
+c=======================================================================
+c Ecriture du fichier de redemarrage sous format NetCDF (initialisation)
+c=======================================================================
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iday_end
+      REAL phis(ip1jmp1)
+      CHARACTER*(*) fichnom
+      INTEGER nq
+
+c   Local:
+c   ------
+      INTEGER iq,l
+      CHARACTER str3*3
+      INTEGER length
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr
+      character*20 modname
+      character*80 abort_message
+
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
+c-----------------------------------------------------------------------
+      modname='dynredem'
+
+      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
+      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
+        
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = FLOAT(iim)
+       tab_cntrl(2)  = FLOAT(jjm)
+       tab_cntrl(3)  = FLOAT(llm)
+       tab_cntrl(4)  = FLOAT(day_ref)
+       tab_cntrl(5)  = FLOAT(annee_ref)
+       tab_cntrl(6)  = rad
+       tab_cntrl(7)  = omeg
+       tab_cntrl(8)  = g
+       tab_cntrl(9)  = cpp
+       tab_cntrl(10) = kappa
+       tab_cntrl(11) = daysec
+       tab_cntrl(12) = dtvr
+       tab_cntrl(13) = etot0
+       tab_cntrl(14) = ptot0
+       tab_cntrl(15) = ztot0
+       tab_cntrl(16) = stot0
+       tab_cntrl(17) = ang0
+       tab_cntrl(18) = pa
+       tab_cntrl(19) = preff
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(20)  = clon
+       tab_cntrl(21)  = clat
+       tab_cntrl(22)  = grossismx
+       tab_cntrl(23)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(24) = 1.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = taux
+       tab_cntrl(29) = tauy
+      ELSE
+       tab_cntrl(24) = 0.
+       tab_cntrl(25) = dzoomx
+       tab_cntrl(26) = dzoomy
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = 0.
+       tab_cntrl(29) = 0.
+       IF( ysinus )  tab_cntrl(27) = 1.
+      ENDIF
+
+       tab_cntrl(30) = FLOAT(iday_end)
+       tab_cntrl(31) = FLOAT(itau_dyn + itaufin)
+c
+c    .........................................................
+c
+c Creation du fichier:
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier demmarage dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28,
+     .                       "Numero naturel des couches s")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Numero naturel des couches sigma")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient A pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26,
+     .                       "Coefficient B pour hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Coefficients de passage cov. <-> contra. <--> naturel
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse U")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Vitesse V")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11,
+     .                       "Temperature")
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF (iq.GT.99) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ELSE
+         str3(1:1)='q'
+         WRITE(str3(2:3),'(i2.2)') iq
+         ierr = NF_DEF_VAR (nid,str3,NF_FLOAT,4,dims4,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "Traceurs "//str3)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                       "C est quoi ?")
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                       "Pression au sol")
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end
+      PRINT*,'rad,omeg,g,cpp,kappa',
+     ,        rad,omeg,g,cpp,kappa
+
+      RETURN
+      END
+      SUBROUTINE dynredem1(fichnom,time,
+     .                     vcov,ucov,teta,q,nq,masse,ps)
+      IMPLICIT NONE
+c=================================================================
+c  Ecriture du fichier de redemarrage sous format NetCDF
+c=================================================================
+#include "dimensions.h"
+#include "paramet.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+
+      INTEGER nq, l
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) 
+      REAL teta(ip1jmp1,llm)                   
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm)                   
+      REAL q(ip1jmp1,llm,nq)
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid
+      INTEGER ierr
+      INTEGER iq
+      CHARACTER str3*3
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+      modname = 'dynredem1'
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+
+c  Ecriture/extension de la coordonnee temps
+
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable temps n est pas definie'
+         CALL abort_gcm(modname,abort_message,ierr)
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time
+
+c  Ecriture des champs
+c
+      ierr = NF_INQ_VARID(nid, "ucov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ucov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vcov", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable vcov n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "teta", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable teta n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,teta)
+#endif
+
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF (iq.GT.99) THEN
+          PRINT*, "Trop de traceurs"
+          CALL abort
+      ELSE
+          str3(1:1)='q'
+          WRITE(str3(2:3),'(i2.2)') iq
+          ierr = NF_INQ_VARID(nid, str3, nvarid)
+          IF (ierr .NE. NF_NOERR) THEN
+             PRINT*, "Variable "//str3//" n est pas definie"
+             CALL abort
+          ENDIF
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq))
+#else
+          ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq))
+#endif
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "masse", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable masse n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,masse)
+#endif
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ener.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ener.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ener.h	(revision 428)
@@ -0,0 +1,11 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'ener.h'
+
+      COMMON/ener/ang0,etot0,ptot0,ztot0,stot0,
+     *            ang,etot,ptot,ztot,stot,rmsdpdt ,
+     *            rmsv,gtot(llmm1)
+
+      REAL ang0,etot0,ptot0,ztot0,stot0,
+     s     ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/enercin.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/enercin.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/enercin.F	(revision 428)
@@ -0,0 +1,96 @@
+      SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur: P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c .. calcul de l'energie cinetique aux niveaux s  ......
+c *********************************************************************
+c  vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg .
+c  ecin         est  un  argument de sortie pour le s-pg
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ),
+     * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm )
+
+      REAL ecinni( iip1 ),ecinsi( iip1 )
+
+      REAL ecinpn, ecinps
+      INTEGER     l,ij,i
+
+      EXTERNAL    SSUM
+      REAL        SSUM
+
+
+
+c                 . V
+c                i,j-1
+
+c      alpha4 .       . alpha1
+
+
+c        U .      . P     . U
+c       i-1,j    i,j      i,j
+
+c      alpha3 .       . alpha2
+
+
+c                 . V
+c                i,j
+
+c    
+c  L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est :
+c       Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 )  +
+c              0.5 * U(i  ,j)**2 *( alpha1 + alpha2 )  +
+c              0.5 * V(i,j-1)**2 *( alpha1 + alpha4 )  +
+c              0.5 * V(i,  j)**2 *( alpha2 + alpha3 )
+
+
+      DO 5 l = 1,llm
+
+      DO 1  ij = iip2, ip1jm -1
+      ecin( ij+1, l )  =    0.5  *
+     * (   ucov( ij   ,l ) * ucont( ij   ,l ) * alpha3p4( ij +1 )   +
+     *     ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 )   +
+     *     vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 )   +
+     *     vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 )   )
+   1  CONTINUE
+
+c    ... correction pour  ecin(1,j,l)  ....
+c    ...   ecin(1,j,l)= ecin(iip1,j,l) ...
+
+CDIR$ IVDEP
+      DO 2 ij = iip2, ip1jm, iip1
+      ecin( ij,l ) = ecin( ij + iim, l )
+   2  CONTINUE
+
+c     calcul aux poles  .......
+
+
+      DO 3 i = 1, iim
+      ecinni(i) = vcov(    i  ,  l) * vcont(    i    ,l) * aire(   i   )
+      ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm)
+   3  CONTINUE
+
+      ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln
+      ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols
+
+      DO 4 ij = 1,iip1
+      ecin(   ij     , l ) = ecinpn
+      ecin( ij+ ip1jm, l ) = ecinps
+   4  CONTINUE
+
+   5  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/etat0_netcdf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/etat0_netcdf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/etat0_netcdf.F	(revision 428)
@@ -0,0 +1,682 @@
+c
+c $Header$
+c
+      SUBROUTINE etat0_netcdf (interbar, masque, pctsrf)
+    
+      USE startvar
+      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
+      !
+#include "comgeom2.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "indicesol.h"
+#include "dimphy.h"
+#include "dimsoil.h"
+#include "temps.h"
+      !
+      LOGICAL interbar
+      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, 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), fder(klon)
+      REAL :: deltat(klon), frugs(klon,nbsrf), agesno(klon,nbsrf)
+      REAL :: 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)      !
+      real :: clwcon(klon,klev),rnebcon(klon,klev),ratqs(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
+      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, ji,ii1,ii2
+      REAL :: xpi
+      !
+      REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm)
+      REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1)
+      REAL :: workvar(iip1,jjp1,llm)
+      !
+      REAL ::  prefkap, unskap
+      !
+      REAL :: q_sat
+      EXTERNAL q_sat
+      real :: time_step,t_ops,t_wrt
+
+#include "comdissnew.h"
+#include "control.h"
+#include "serre.h"
+#include "clesphys.h"
+
+      INTEGER  ::        longcles
+      PARAMETER      ( longcles  = 20 )
+      REAL :: clesphy0 ( longcles       )
+      REAL :: p(iip1,jjp1,llm)
+      INTEGER :: itau, iday
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      real :: time
+      REAL :: phi(ip1jmp1,llm)
+      REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL :: w(ip1jmp1,llm)
+      REAL ::phystep,co2_ppm,solaire
+      INTEGER :: radpas
+       real zrel(iip1*jjp1),chmin,chmax
+
+      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)
+      real zx_tmp_2d(iim,jjp1)
+      !
+      !   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)
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+      dtvr   = daysec/FLOAT(day_step)
+      print*,'dtvr',dtvr
+
+      CALL inicons0()
+      CALL inigeom()
+      !
+      CALL inifilr()
+      !
+      latfi(1) = ASIN(1.0)
+      DO j = 2, jjm
+        DO i = 1, iim
+          latfi((j-2)*iim+1+i)=  rlatu(j)
+        ENDDO
+      ENDDO
+      latfi(klon) = - ASIN(1.0)
+      !
+      lonfi(1) = 0.0
+      DO j = 2, jjm
+        DO i = 1, iim
+          lonfi((j-2)*iim+1+i) =  rlonv(i)
+        ENDDO
+      ENDDO
+      lonfi(klon) = 0.0
+      !
+      xpi = 2.0 * ASIN(1.0)
+      DO ig = 1, klon
+        latfi(ig) = latfi(ig) * 180.0 / xpi
+        lonfi(ig) = lonfi(ig) * 180.0 / xpi
+      ENDDO
+      !
+
+
+C
+C En cas de simulation couplee, lecture du masque ocean issu du modele ocean
+C utilise pour calculer les poids et pour assurer l'adequation entre les
+C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque 
+C a partir du fichier relief
+C
+
+      write(*,*)'Essai de lecture masque ocean'
+      iret = nf_open("o2a.nc", NF_NOWRITE, nid_o2a)
+      if (iret .ne. 0) then
+        write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve'
+        write(*,*)'Run force'
+        varname = 'masque'
+        masque(:,:) = 0.0
+        CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0,
+     ,  jjm ,rlonu,rlatv , interbar )
+        WRITE(*,*) 'MASQUE construit : Masque'
+        WRITE(*,'(97I1)') nINT(masque(:,:))
+        call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq)
+        WHERE (zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 0.
+        END WHERE 
+        WHERE (1. - zmasq(1 : klon) .LT. EPSFRA)
+            zmasq(1 : klon) = 1.
+        END WHERE 
+      else
+        couple = .true.
+        iret = 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
+        write(*,*)'ocemask '
+        write(*,'(96i1)')int(ocemask)
+        ocemask_fi(1) = ocemask(1,1)
+        do j = 2, jjm
+          do i = 1, iim
+            ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j)
+          enddo
+        enddo
+        ocemask_fi(klon) = ocemask(1,jjp1)
+        zmasq = 1. - ocemask_fi
+      endif
+
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+
+      varname = 'relief'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      orog(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0 ,
+     , jjm ,rlonu,rlatv , interbar, masque )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Relief'
+!      WRITE(*,'(49I1)') INT(orog(:,:))
+      !
+      varname = 'rugosite'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      rugo(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0 ,
+     , jjm, rlonu,rlatv , interbar )
+      !
+      WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' 
+!      WRITE(*,'(49I1)') INT(rugo(:,:)*10)
+      !
+C
+C on initialise les sous surfaces
+C
+      pctsrf=0.
+c
+      varname = 'psol'
+      psol(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0 ,
+     , jjm ,rlonu,rlatv , interbar )
+      !
+      !  Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM 
+      !  anyway.
+      !
+!      WRITE(*,*) 'PSOL :', psol(10,20)
+!      WRITE(*,*) ap(:), bp(:)
+      CALL pression(ip1jmp1, ap, bp, psol, p3d)
+!      WRITE(*,*) 'P3D :', p3d(10,20,:)
+      CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar)
+!      WRITE(*,*) 'PK:', pk(10,20,:)
+      !
+      !
+      !
+      prefkap =  preff  ** kappa
+!      WRITE(*,*) 'unskap, cpp,  preff :', unskap, cpp,  preff
+      DO l = 1, llm
+        DO j=1,jjp1
+          DO i =1, iip1
+            pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap
+           ENDDO
+        ENDDO
+      ENDDO
+      !
+!      WRITE(*,*) 'PLS :', pls(10,20,:)
+      !
+      varname = 'surfgeo'
+      phis(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0 ,
+     , jjm ,rlonu,rlatv, interbar )
+      !
+      varname = 'u'
+      uvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls,
+     . workvar, uvent, 0.0, jjm ,rlonv, rlatv, interbar )
+      !  
+      varname = 'v'
+      vvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls,
+     . workvar, vvent, 0.0, jjp1, rlonu, rlatu, interbar )
+      !
+      varname = 't'
+      t3d(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . workvar, t3d, 0.0 , jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      varname = 'tpot'
+      tpot(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . pk, tpot, 0.0 , jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)),
+     .                          maxval(t3d(:,:,:))
+      WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)),
+     .                          maxval(pls(:,:,:))
+      DO l = 1, llm
+        DO j=1,jjp1
+          DO i =1, iip1-1
+           qsat(i,j,l) = q_sat(t3d(i,j,l),pls(i,j,l)/100. )
+          ENDDO
+          qsat(iip1,j,l) = qsat(1,j,l)
+        ENDDO
+      ENDDO
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      !
+      WRITE(*,*) 'QSAT :', qsat(10,20,:)
+      !
+      varname = 'q'
+      qd(:,:,:) = 0.0
+      q3d(:,:,:,:) = 0.0
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . qsat, qd, 0.0, jjm, rlonu, rlatv , interbar )
+      q3d(:,:,:,1) = qd(:,:,:)
+      !
+      varname = 'tsol'
+      ! This line needs to be replaced by a call to restget to get the values in the restart file
+      tsol(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+      WRITE(*,*) 'TSOL construit :'
+!      WRITE(*,'(48I3)') INT(TSOL(2:klon)-273)
+      !
+      varname = 'qsol'
+      qsol(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0,
+     .   jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'snow'
+      sn(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rads'
+      radsol(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0,
+     .    jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'deltat'
+      deltat(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,deltat,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      !
+      varname = 'rugmer'
+      rugmer(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      !
+!      varname = 'agesno'
+!      agesno(:) = 0.0
+!      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0,
+!     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zmea'
+      zmea(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+
+      varname = 'zstd'
+      zstd(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zsig'
+      zsig(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zgam'
+      zgam(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zthe'
+      zthe(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zpic'
+      zpic(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+      varname = 'zval'
+      zval(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0,
+     .     jjm, rlonu, rlatv , interbar )
+c
+      rugsrel(:) = 0.0
+      IF(ok_orodr)  THEN
+        DO i = 1, iip1* jjp1
+         rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. )
+        ENDDO
+      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
+C
+C verif que somme des sous surface = 1
+C
+      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+     $    .GT. EPSFRA)
+      IF (ji .NE. 0) THEN
+          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+      ENDIF 
+
+!      where (pctsrf(1:klon, is_ter) >= .5) 
+!        pctsrf(1:klon, is_ter) = 1.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_lic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 1.
+!        zmasq = 1.
+!      endwhere
+!      where (pctsrf(1:klon, is_oce) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 1.
+!        pctsrf(1:klon, is_sic) = 0.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      where (pctsrf(1:klon, is_sic) >= .5) 
+!        pctsrf(1:klon, is_ter) = 0.
+!        pctsrf(1:klon, is_oce) = 0.
+!        pctsrf(1:klon, is_sic) = 1.
+!        pctsrf(1:klon, is_lic) = 0.
+!        zmasq = 0.
+!      endwhere
+!      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+C
+C verif que somme des sous surface = 1
+C
+!      ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) 
+!     $    .GT. EPSFRA)
+!      IF (ji .NE. 0) THEN
+!          WRITE(*,*) 'pb repartition sous maille pour ',ji,' points'
+!     ENDIF 
+
+      CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d)
+      write(*,*)'zmasq = '
+      write(*,'(96i1)')nint(zx_tmp_2d)
+      call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque)
+      WRITE(*,*) 'MASQUE construit : Masque'
+      WRITE(*,'(97I1)') nINT(masque(:,:))
+
+
+
+C Calcul intermediaire
+c 
+      CALL massdair( p3d, masse  )
+c
+
+      print *,' ALPHAX ',alphax
+
+      DO  l = 1, llm
+        DO  i    = 1, iim
+          xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+          xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+        ENDDO
+          xpn      = SUM(xppn)/apoln
+          xps      = SUM(xpps)/apols
+        DO i   = 1, iip1
+          masse(   i   ,   1     ,  l )   = xpn
+          masse(   i   ,   jjp1  ,  l )   = xps
+        ENDDO
+      ENDDO
+      q3d(iip1,:,:,:) = q3d(1,:,:,:)
+      phis(iip1,:) = phis(1,:)
+
+C Ecriture
+
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'sortie inidissip'
+      itau = 0
+      itau_dyn = 0
+      itau_phy = 0
+      iday = dayref +itau/day_step
+      time = FLOAT(itau-(iday-dayref)*day_step)/day_step
+c     
+      IF(time.GT.1)  THEN
+       time = time - 1
+       iday = iday + 1
+      ENDIF
+      day_ref = dayref
+      annee_ref = anneeref
+
+      CALL geopot  ( ip1jmp1, tpot  , pk , pks,  phis  , phi   )
+      print*,'sortie geopot'
+      
+      CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,time+iday-dayref   )
+       print*,'sortie caldyn0'     
+      CALL dynredem0("start.nc",dayref,phis,nqmx)
+      print*,'sortie dynredem0'
+      CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,nqmx,masse ,
+     .                            psol)
+      print*,'sortie dynredem1' 
+C
+C Ecriture etat initial physique
+C
+      write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad
+      phystep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (86400./phystep/ FLOAT(nbapp_rad) )
+      write(*,*)'phystep =', phystep, radpas
+      co2_ppm   = 330.0
+      solaire   = 1370.0
+
+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
+      fder = 0.0
+      clwcon = 0.0
+      rnebcon = 0.0
+      ratqs = 0.0
+
+      call phyredem("startphy.nc",phystep,radpas, co2_ppm, solaire,
+     $    latfi, lonfi, pctsrf, tsolsrf, tsoil, deltat, qsolsrf, snsrf, 
+     $    albe, evap, rain_fall, snow_fall, solsw, sollw, fder,
+     $    radsol, frugs,  agesno, 
+     $    zmea, zstd, zsig, zgam, zthe, zpic, zval, rugsrel, 
+     $    t_ancien, q_ancien, rnebcon, ratqs, clwcon)
+
+C     Sortie Visu pour les champs dynamiques
+      print*,'sortie visu'
+      time_step = 1.
+      t_ops = 2.
+      t_wrt = 2.
+      itau = 2.
+      visu_file='Etat0_visu.nc'
+      CALL initdynav(visu_file,dayref,anneeref,time_step,
+     .              t_ops, t_wrt, nqmx, visuid)
+      CALL writedynav(visuid, nqmx, itau,vvent ,
+     .                uvent,tpot,pk,phi,q3d,masse,psol,phis)
+      print*,'entree histclo'
+      CALL histclo
+      RETURN
+      !
+      END SUBROUTINE etat0_netcdf
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exnerF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exnerF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exnerF	(revision 428)
@@ -0,0 +1,88 @@
+      SUBROUTINE  exner ( ngrid, ps, p, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    .... ngrid, ps,p  sont des argum.d'entree  au sous-prog.   ....
+c    .... pks,pk,pkf   sont des argum.de sortie au sous-prog.   ....
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid)
+      INTEGER l, ij
+      REAL alpha(ngrid,llm),beta(ngrid,llm),unpl2k,delta
+      EXTERNAL filtreg
+c
+      unpl2k    = 1.+ 2.* kappa
+c
+      DO   ij  = 1, ngrid
+       pks(ij) = cpp * (ps(ij)/preff) ** kappa
+      ENDDO
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = 1, ngrid
+        delta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / delta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / delta   
+        ENDDO
+c
+      ENDDO
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+      DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .true., 1)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exner_hyb.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exner_hyb.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/exner_hyb.F	(revision 428)
@@ -0,0 +1,112 @@
+      SUBROUTINE  exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf )
+c
+c     Auteurs :  P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... alpha,beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 
+c    couches .   Pk(l) sera calcule aux milieux  des couches l ,entre les
+c    pressions p(l) et p(l+1) ,definis aux interfaces des llm couches .
+c   ************************************************************************
+c  .. N.B : Au sommet de l'atmosphere,  p(llm+1) = 0. , et ps et pks sont
+c    la pression et la fonction d'Exner  au  sol  .
+c
+c                                 -------- z                                   
+c    A partir des relations  ( 1 ) p*dz(pk) = kappa *pk*dz(p)      et
+c                            ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1)
+c    ( voir note de Fr.Hourdin )  ,
+c
+c    on determine successivement , du haut vers le bas des couches, les 
+c    coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 
+c    puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches,  
+c     pk(ij,l)  donne  par la relation (2),  pour l = 2 a l = llm .
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "serre.h"
+
+      INTEGER  ngrid
+      REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm)
+      REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL unpl2k,dellta
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL filtreg, SSUM
+c
+      
+      unpl2k    = 1.+ 2.* kappa
+c
+      DO   ij  = 1, ngrid
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
+
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
+c
+c
+c    .... Calcul des coeff. alpha et beta  pour la couche l = llm ..
+c
+      DO     ij      = 1, ngrid
+       alpha(ij,llm) = 0.
+       beta (ij,llm) = 1./ unpl2k
+      ENDDO
+c
+c     ... Calcul des coeff. alpha et beta  pour l = llm-1  a l = 2 ...
+c
+      DO l = llm -1 , 2 , -1
+c
+        DO ij = 1, ngrid
+        dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k )
+        alpha(ij,l)  = - p(ij,l+1) / dellta * alpha(ij,l+1)
+        beta (ij,l)  =   p(ij,l  ) / dellta   
+        ENDDO
+c
+      ENDDO
+c
+c  ***********************************************************************
+c     .....  Calcul de pk pour la couche 1 , pres du sol  ....
+c
+      DO   ij   = 1, ngrid
+       pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) )  /
+     *    (  p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) )
+      ENDDO
+c
+c    ..... Calcul de pk(ij,l) , pour l = 2 a l = llm  ........
+c
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+         pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1)
+        ENDDO
+      ENDDO
+c
+c
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/extrapol.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/extrapol.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/extrapol.F	(revision 428)
@@ -0,0 +1,198 @@
+C
+C $Header$
+C
+      SUBROUTINE extrapol (pfild, kxlon, kylat, pmask,
+     .                   norsud, ldper, knbor, pwork)
+      IMPLICIT none
+c
+c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997)
+c Fill up missed values by using the neighbor points
+c
+      INTEGER kxlon, kylat ! longitude and latitude dimensions (Input)
+      INTEGER knbor ! minimum neighbor number (Input)
+      LOGICAL norsud ! True if field is from North to South (Input)
+      LOGICAL ldper ! True if take into account the periodicity (Input)
+      REAL pmask ! mask value (Input)
+      REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output)
+      REAL pwork(kxlon,kylat) ! working space
+c
+      REAL zwmsk
+      INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat
+      INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates
+      REAL zmask(9)
+C
+C  We search over the eight closest neighbors
+C
+C            j+1  7  8  9
+C              j  4  5  6    Current point 5 --> (i,j)
+C            j-1  1  2  3
+C                i-1 i i+1
+c
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      incre = 0
+c
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         pwork(i,j) = pfild(i,j)
+      ENDDO
+      ENDDO
+c
+C* To avoid problems in floating point tests
+      zwmsk = pmask - 1.0
+c
+200   CONTINUE
+      incre = incre + 1
+      DO 99999 j = 1, kylat
+      DO 99999 i = 1, kxlon
+      IF (pfild(i,j).GT. zwmsk) THEN
+         pwork(i,j) = pfild(i,j)
+         inbor = 0
+         ideb = 1
+         ifin = 9
+C
+C* Fill up ix array
+         ix(1) = MAX (1,i-1)
+         ix(2) = i
+         ix(3) = MIN (kxlon,i+1)
+         ix(4) = MAX (1,i-1)
+         ix(5) = i
+         ix(6) = MIN (kxlon,i+1)
+         ix(7) = MAX (1,i-1)
+         ix(8) = i
+         ix(9) = MIN (kxlon,i+1)
+C
+C* Fill up iy array
+         jy(1) = MAX (1,j-1)
+         jy(2) = MAX (1,j-1)
+         jy(3) = MAX (1,j-1)
+         jy(4) = j
+         jy(5) = j
+         jy(6) = j
+         jy(7) = MIN (kylat,j+1)
+         jy(8) = MIN (kylat,j+1)
+         jy(9) = MIN (kylat,j+1)
+C
+C* Correct latitude bounds if southernmost or northernmost points
+         IF (j .EQ. 1) ideb = 4
+         IF (j .EQ. kylat) ifin = 6
+C
+C* Account for periodicity in longitude
+C
+         IF (ldper) THEN 
+            IF (i .EQ. kxlon) THEN
+               ix(3) = 1
+               ix(6) = 1
+               ix(9) = 1
+            ELSE IF (i .EQ. 1) THEN
+               ix(1) = kxlon
+               ix(4) = kxlon
+               ix(7) = kxlon
+            ENDIF
+         ELSE
+            IF (i .EQ. 1) THEN
+               ix(1) = i
+               ix(2) = i + 1
+               ix(3) = i
+               ix(4) = i + 1
+               ix(5) = i
+               ix(6) = i + 1
+            ENDIF 
+            IF (i .EQ. kxlon) THEN
+               ix(1) = i -1
+               ix(2) = i
+               ix(3) = i - 1
+               ix(4) = i
+               ix(5) = i - 1
+               ix(6) = i
+            ENDIF
+C
+            IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN 
+               jy(1) = MAX (1,j-1)
+               jy(2) = MAX (1,j-1)
+               jy(3) = j
+               jy(4) = j
+               jy(5) = MIN (kylat,j+1)
+               jy(6) = MIN (kylat,j+1)
+C
+               ideb = 1
+               ifin = 6
+               IF (j .EQ. 1) ideb = 3
+               IF (j .EQ. kylat) ifin = 4
+            ENDIF
+         ENDIF ! end for ldper test
+C
+C* Find unmasked neighbors
+C
+         DO 230 k = ideb, ifin
+            zmask(k) = 0.
+            ilon = ix(k)
+            jlat = jy(k)
+            IF (pfild(ilon,jlat) .LT. zwmsk) THEN
+               zmask(k) = 1.
+               inbor = inbor + 1
+            ENDIF
+ 230     CONTINUE
+C
+C* Not enough points around point P are unmasked; interpolation on P 
+C  will be done in a future call to extrap.
+C
+         IF (inbor .GE. knbor) THEN
+            pwork(i,j) = 0.
+            DO k = ideb, ifin
+               ilon = ix(k)
+               jlat = jy(k)
+               pwork(i,j) = pwork(i,j)
+     $                      + pfild(ilon,jlat) * zmask(k)/FLOAT(inbor)
+            ENDDO
+         ENDIF
+C
+      ENDIF
+99999 CONTINUE
+C
+C*    3. Writing back unmasked field in pfild
+C        ------------------------------------
+C
+C* pfild then contains:
+C     - Values which were not masked
+C     - Interpolated values from the inbor neighbors
+C     - Values which are not yet interpolated
+C
+      idoit = 0
+      DO j = 1, kylat
+      DO i = 1, kxlon
+         IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1
+         pfild(i,j) = pwork(i,j)
+      ENDDO
+      ENDDO
+c
+      IF (idoit .ne. 0) GOTO 200
+ccc      PRINT*, "Number of extrapolation steps incre =", incre
+c
+      IF (norsud) THEN
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pwork(i,j) = pfild(i,kylat-j+1)
+         ENDDO
+         ENDDO
+         DO j = 1, kylat
+         DO i = 1, kxlon
+            pfild(i,j) = pwork(i,j)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass.F	(revision 428)
@@ -0,0 +1,107 @@
+      SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv )
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van, F. Hourdin  .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c *********************************************************************
+c     .... calcul du flux de masse  aux niveaux s ......
+c *********************************************************************
+c   massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg .
+c       pbaru  et pbarv            sont des argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) ,
+     * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),
+     * pbarv( ip1jm,llm )
+
+      REAL apbarun( iip1 ),apbarus( iip1 )
+
+      REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0
+      INTEGER  l,ij,i
+
+      EXTERNAL   SSUM
+      REAL       SSUM
+
+
+      DO  5 l = 1,llm
+
+      DO  1 ij = iip2,ip1jm
+      pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l )
+   1  CONTINUE
+
+      DO 3 ij = 1,ip1jm
+      pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+c    ................................................................
+c     calcul de la composante du flux de masse en x aux poles .......
+c    ................................................................
+c     par la resolution d'1 systeme de 2 equations .
+
+c     la premiere equat.decrivant le calcul de la divergence en 1 point i
+c     du pole,ce calcul etant itere de i=1 a i=im .
+c                 c.a.d   ,
+c     ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i)   =
+c                                           - somme de ( pbarv(n) )/aire pole
+
+c     l'autre equat.specifiant que la moyenne du flux de masse au pole est =0.
+c     c.a.d    somme de pbaru(n)*aire locale(n) = 0.
+
+c     on en revient ainsi a determiner la constante additive commune aux pbaru
+c     qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt
+c     i=1 .
+c     i variant de 1 a im
+c     n variant de 1 a im
+
+      sairen = SSUM( iim,  aire(   1     ), 1 )
+      saireun= SSUM( iim, aireu(   1     ), 1 )
+      saires = SSUM( iim,  aire( ip1jm+1 ), 1 )
+      saireus= SSUM( iim, aireu( ip1jm+1 ), 1 )
+
+      DO 20 l = 1,llm
+
+      ctn =  SSUM( iim, pbarv(    1     ,l),  1 )/ sairen
+      cts =  SSUM( iim, pbarv(ip1jmi1+ 1,l),  1 )/ saires
+
+      pbaru(    1   ,l )=   pbarv(    1     ,l ) - ctn * aire(    1    )
+      pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 )
+
+      DO 11 i = 2,iim
+      pbaru(    i    ,l ) = pbaru(   i - 1   ,l )    +
+     *                      pbarv(    i      ,l ) - ctn * aire(   i    )
+
+      pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l )    -
+     *                      pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm)
+  11  CONTINUE
+      DO 12 i = 1,iim
+      apbarun(i) = aireu(    i   ) * pbaru(   i    , l)
+      apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l)
+  12  CONTINUE
+      ctn0 = -SSUM( iim,apbarun,1 )/saireun
+      cts0 = -SSUM( iim,apbarus,1 )/saireus
+      DO 14 i = 1,iim
+      pbaru(   i    , l) = 2. * ( pbaru(   i    , l) + ctn0 )
+      pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 )
+  14  CONTINUE
+
+      pbaru(   iip1 ,l ) = pbaru(    1    ,l )
+      pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l )
+  20  CONTINUE
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass3d.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass3d.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass3d.F	(revision 428)
@@ -0,0 +1,61 @@
+      SUBROUTINE flumass3d(ucont,vcont,pext,pbaru,pbarv,w,dp)
+c%W%	%G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 17/02/93
+c   -------
+c
+c   Subject:
+c   ------
+c   calcul du flux de masse dans les trois directions
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+
+      REAL pext(ip1jmp1)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL dp(ip1jmp1)
+      REAL w(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL pbarx(ip1jmp1),pbary(ip1jm),pbarxy(ip1jm)
+      REAL convm(ip1jmp1,llm)
+
+c-----------------------------------------------------------------------
+
+      CALL pbar(pext,pbarx,pbary,pbarxy)
+      CALL flumass(pbarx,pbary,vcont,ucont,pbaru,pbarv)
+      CALL convmas(pbaru,pbarv,convm)
+      CALL SCOPY(ip1jmp1,convm,1,dp,1)
+      CALL vitvert(convm,w)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass_scal.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass_scal.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/flumass_scal.F	(revision 428)
@@ -0,0 +1,80 @@
+      SUBROUTINE flumass_scal(pbaru,pbarv,w,v)
+c%W%%G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 17/02/93
+c   -------
+c
+c   Subject:
+c   ------
+c   On ramene les flux de masse aux points scalaires.
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm),w(ip1jmp1,llm)
+      REAL v(ip1jmp1,llm,3)
+
+c   Local:
+c   ------
+
+      INTEGER ij,l
+
+c-----------------------------------------------------------------------
+
+c   transport zonal:
+c   ----------------
+      DO l=1,llm
+	 DO ij=2,ip1jmp1
+            v(ij,l,1)=.5*(pbaru(ij,l)+pbaru(ij-1,l))
+	 ENDDO
+      ENDDO
+      CALL SCOPY(jjp1*llm,v(iip1,1,1),iip1,v(1,1,1),iip1)
+
+c   Transport meridien:
+c   -------------------
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+	    v(ij,l,2)=.5*(pbarv(ij,l)+pbarv(ij-iip1,l))
+	 ENDDO
+	 DO ij=1,iip1
+	    v(ij,l,2)=0.
+	    v(ip1jm+ij,l,2)=0.
+	 ENDDO
+      ENDDO
+
+c   Transport vertical:
+c   -------------------
+      DO l=1,llm-1
+	 DO ij=1,ip1jmp1
+	    v(ij,l,3)=.5*(w(ij,l)+w(ij,l+1))
+	 ENDDO
+      ENDDO
+      DO ij=1,ip1jmp1
+	 v(ij,llm,3)=.5*w(ij,llm)
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fluxstokenc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fluxstokenc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fluxstokenc.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/fxhyp.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxhyp.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxhyp.F	(revision 428)
@@ -0,0 +1,446 @@
+c
+c $Header$
+c
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,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     .... 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,ii1,ii2
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL*8 heavyside
+       EXTERNAL coefpoly,heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( 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) = - pi + FLOAT(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxy.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxy.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxy.F	(revision 428)
@@ -0,0 +1,66 @@
+      SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+      IMPLICIT NONE
+
+c     Auteur  :  P. Le Van
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c           a tangente sinusoidale et eventuellement avec zoom  .
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "serre.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_new.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhypF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhypF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhypF	(revision 428)
@@ -0,0 +1,594 @@
+       SUBROUTINE fxyhyp( clat,  rlatu,yprimu ,  rlatv,yprimv   ,
+     *                         rlatu1 ,yprimu1, rlatu2,yprimu2   )
+c
+       IMPLICIT NONE
+c   -----------------------
+c     Auteur  :  P. Le Van 
+c   -----------------------
+c
+c .. Objet : Calcul d'une fonction f(y)  ayant pour derivee une tangente
+c        hyperbolique , donc des ordonnees y de la grille horizontale ,
+c       ainsi que ses derivees yprim , utlisees dans  Inigeom  .
+c
+c
+c ....  rlatu   =  fxyhyp (   j      )     avec 1  <= j  <= jjm + 1 
+c ....  rlatv   =  fxyhyp ( j + 0.5  )     avec 1  <= j  <= jjm
+c ....  rlatu1  =  fxyhyp ( j + 0.25 )     avec 1  <= j  <= jjm 
+c ....  rlatu2  =  fxyhyp ( j + 0.75 )     avec 1  <= j  <= jjm
+c
+
+       INTEGER nmax
+       PARAMETER ( nmax = 100 000 )
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+c
+c    .................   Arguments     ................................
+c
+c   clat est (en degres) la latitude du centre du zoom : arg. d'entree
+c    Les autres arguments     sont                des argum. de sortie
+c
+       REAL clat
+       REAL rlatu(jjp1),rlatv(jjm),yprimu(jjp1),yprimv(jjm)
+       REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm)
+c
+c    .................................................................
+c
+c             ...... .  Variables  locales   .........   
+c
+       REAL yprim( 0:nmax ),yi( 0:nmax ),yf( 0:nmax )
+       REAL yyy(0:nmax)
+       REAL delta,den,eps,phij,pijjm,pis2,pis2pyo,pism,psi,psi0
+       REAL rappis2,unpdel,y,yint,yj,yo,yo1,yppp,ypr 
+       REAL yprimin,pisnmax,ydeg
+       INTEGER i,j,it,iter
+c
+c
+c -------------------------------------------------------------------------
+   
+c   On veut calculer  y(Y) et y'(Y) , avec  Y ,latitude de travail =f(j),
+c       et   y , latitude vraie .
+c
+c  Pour cela ,on se donne pour  Y'(y) une fonction hyperbolique calculee
+c  sur  ( 1+ nmax ) points ( plus nmax est grand, plus la precision pour 
+c  y(Y)  sera grande ) , on integre Y'(y) sur ces ( 1+nmax) pts  pour
+c  obtenir  Y(y) apres normalisation  , puis on  aura y(Y)  en resolvant
+c   l'equation  Y(yj) = Yj  par Newton_Raphson ,  avec Yj = f(j) =
+c   pi/2 + pi/jjm ( 1.- j)  pour les scalaires  ( j =1, jjm+1 )
+c   On en tire donc  yj  qui correspond  a  la ligne  j   .
+c   On a ensuite pour les derivees :  y'(Y) = 1./ Y'(y) * ( pi/ jjm )
+c
+c   On calculera   y(Y) et y'(Y)  successivement   aux  latitudes  de  U 
+c     ,  V  ,  U + 0.25 , U + 0.75   .
+c
+c   Notations ; 
+c  -------------
+c     yi    represente les nmax+1 latitudes de depart ( -pi/2 a pi/2 )
+c  yyy(nmax)  repres.  l'integrale de Y'(y) de - pi/2 a pi/2
+c    yprim  represente  Y'(y)
+c     yf    represente  Y (y)
+c
+c     yo    represente la latitude du centre du zoom
+c    delta  represente la demi largeur du zoom
+c
+c
+c  N.B :  La fonction hyperbolique Y'(y) est  definie comme suit :
+c ------
+c
+c    Y' = TANH ( ( psio - psi )/psi*(1- psi) )  avec  :
+c
+c          psi =  ( y - yo ) / ( pi/2 - yo )  si     yo < y < pi/2
+c          psi =  (yo -  y )/  ( pi/2 + yo )  si - pi/2 < y < yo
+c
+c
+c  ....  yo    represente la latitude du centre du zoom         .....
+c
+c  ....  psi0  et delta sont des parametres variant entre 0 et 1  ....
+c----------------------------------------------------------------------
+c
+cc     psi0 = 0.3 et  delta = 0.5  sont les valeurs qui conviennent 
+c      pour  *** iim = 96  et jjm = 72 ***  , d'apres des tests sur
+c      les valeurs du Laplacien itere ( 2 fois) , analytiques et cal-
+c      culees.   Pour d'autres valeurs de  iim et jjm , on peut tester
+c      les nouvelles valeurs de psi0 et delta en lancant  testfxyhyp .
+c
+c ----------------------------------------------------------------------
+c    Fxyhp  est appele par inigeom  a la place de  fxynew (  fonction
+c    a derivee sinusoidale )  si la variable logique fxyhypb , lue par
+c    defrun_new  est  . TRUE.    .
+c ----------------------------------------------------------------------
+c
+
+       pi     =  2.*ASIN( 1. )
+       pis2   =  pi/2.
+       yo     =  clat  * pi/180.
+       psi0   =  0.3
+       delta  =  0.5
+       unpdel =  1. + delta
+       eps    =  .1e-7
+c
+       PRINT *,' ----------------------------------------------------'
+       PRINT 1,    psi0,delta,clat
+       PRINT *,' ----------------------------------------------------'
+
+       pisnmax =  pi/FLOAT(nmax)
+       yi(0)   = - pis2
+
+       DO i = 1, nmax
+        yi(i)= - pis2 + FLOAT(i)*pisnmax
+       ENDDO
+
+       yyy(0)=  0.
+
+c
+c     ***************************************************************
+c     ************      Cas   ou   yo  <  0.     ********************
+c     ***************************************************************
+c
+       IF( yo.LT. 0. )   THEN
+c
+       pis2pyo = - pis2 + yo
+       rappis2 = ( -pis2-yo)/pis2pyo
+       rappis2 = rappis2 * rappis2
+c
+        DO 5 i = 1, nmax
+
+        y = 0.5 * ( yi(i)+ yi(i-1) )
+        IF( y.LT.- pis2.OR.y.GT.pis2 )  STOP 0
+
+        IF(y.GT.yo)  THEN
+        psi = (y-yo)/(pis2-yo)
+        ypr =  TANH( (psi0 -psi)/(psi*(1.-psi)) )
+         
+        ELSE
+        psi = (yo-y)/(pis2+yo)
+        ypr = 1.-rappis2 + rappis2* TANH ( (psi0 -psi)/(psi*(1.-psi)) )
+        ENDIF
+
+        yyy(i)= yyy(i-1)+ ypr*(yi(i)-yi(i-1))
+
+ 5    CONTINUE
+
+       den = unpdel + yyy(nmax)/pi
+
+       yyy(0)=   0.
+       yf(0) = - pis2
+
+       yprim(nmax) = -1.
+       yprim(0)    = 1.- rappis2 - rappis2
+
+       DO 12 i =  0 ,nmax
+        y = yi(i)
+       IF(y.LT.-pis2.OR.y.GT.pis2)  STOP 1
+
+       IF(y.LT.yo)  THEN
+           psi = (yo -y)/(pis2+yo)
+         IF(i.NE.0.AND.i.NE.nmax)  THEN 
+         yprim(i) = 1.- rappis2 + rappis2
+     *                 * TANH( (psi0 -psi)/(psi*(1.-psi)) )
+         ENDIF
+       ELSE
+        psi = (y-yo)/(pis2-yo)
+          IF(i.NE.0.AND.i.NE.nmax) THEN
+           yprim(i) =  TANH( (psi0 -psi)/(psi*(1.-psi)) )
+          ENDIF
+       ENDIF
+
+c
+c   ..................................................... 
+c   .......   Normalisation de  Y'(y) et de  Y(y)   .....
+c   .....................................................
+c
+        yprim(i)= ( yprim(i)+ unpdel )/ den
+        yf(i)= (yyy(i)+  unpdel*( yi(i)+ pis2))/ den  - pis2
+c
+ 12    CONTINUE
+c
+      ELSE
+c
+c     **************************************************************
+c     **********          Cas  ou  yo  >=  0 .        **************
+c     **************************************************************
+c
+       pis2pyo = pis2 + yo
+       rappis2 = ( pis2 - yo )/pis2pyo
+       rappis2 = rappis2 * rappis2
+c
+
+       DO 13 i = 1, nmax
+        y= 0.5 * ( yi(i)+ yi(i-1) )
+        IF(y.LT.- pis2.OR.y.GT.pis2)   STOP 2
+
+       IF(y.LT.yo)  THEN
+        psi = (yo -y)/(pis2+yo)
+        ypr =  TANH( (psi0 - psi)/(psi*(1.-psi)) )
+
+       ELSE
+        psi = (y- yo)/(pis2-yo)
+        ypr = 1.-rappis2 + rappis2* TANH ( (psi0 -psi)/(psi*(1.-psi)) )
+
+       ENDIF
+
+        yyy(i)= yyy(i-1)+ ypr*(yi(i)-yi(i-1))
+
+ 13    CONTINUE
+
+       den = unpdel + yyy(nmax)/pi
+
+       yyy(0)= 0.
+       yf(0) = -pis2
+
+       yprim(0)   = -1.
+       yprim(nmax)= 1.- rappis2 - rappis2
+
+       DO 15 i = 0,nmax
+        y = yi(i)
+       IF(y.LT.-pis2.OR.y.GT.pis2)   STOP 3
+
+       IF(y.LT.yo)  THEN
+        psi = (yo -y)/(pis2+yo)
+        IF(i.NE.0.AND.i.NE.nmax) 
+     *   yprim(i) =  TANH( (psi0 -psi)/(psi*(1.-psi)) )
+       ELSE
+        psi = (y- yo)/(pis2-yo)
+        IF(i.NE.0.AND.i.NE.nmax)
+     *   yprim(i) = 1.- rappis2 + rappis2 
+     *               * TANH( (psi0 -psi)/(psi*(1.-psi)) )                              
+       ENDIF
+c   ..................................................... 
+c
+c   .......   Normalisation de  Y'(y) et de  Y(y)   .....
+c   .....................................................
+c
+        yprim(i)= ( yprim(i)+ unpdel )/ den
+        yf(i)= (yyy(i)+  unpdel*( yi(i)+ pis2))/ den  - pis2
+
+ 15    CONTINUE
+
+       ENDIF
+c
+c     ***************************************************************
+
+      yf(0)   = - pis2
+      yf(nmax)=   pis2
+       
+      pijjm = pi/FLOAT(jjm)
+
+c   ...............................................................
+c
+c     Calculs  de y(Y) et y'(Y)   pour les latitudes  de  U   .....
+c
+      PRINT *,' ***************************** '
+      PRINT *,' ***  Calcul de rlatu    ***** '
+      PRINT *,' ***************************** '
+c
+c   ...............................................................
+c
+      PRINT *,' *** j   rlatu  yprimu **** '
+c
+      DO 1500 j=1, jjm +1
+
+      phij = pis2 + pijjm* ( 1.-Float(j) )
+      yo1  = 0.
+      yj   = yo1
+c
+      DO 500 iter = 1,300
+
+      DO 250 it = nmax,0,-1
+      IF( yj.GE.yi(it))  GO TO 350
+250   CONTINUE
+
+      it= 0
+      yj = yi(it)
+
+350   CONTINUE
+       IF(it.EQ.nmax)  THEN
+         yint    = yf(nmax)
+         yprimin = yprim(nmax)
+      ELSE
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yj)  
+c      .....           et   Y'(yj)                             .....
+c  .................................................................
+      yint = (yf(it+1)-yf(it))/(yi(it+1)-yi(it))* ( yj-yi(it) )     +
+     +                           yf(it)
+      yprimin=(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))* ( yj-yi(it) ) +
+     +                           yprim(it)
+      ENDIF
+      yj = yj - (yint-phij)/yprimin
+
+      IF( ABS(yj-yo1).LE.eps) GO TO 550
+      yo1 = yj
+c
+500   CONTINUE
+      PRINT *,' ***   PAS DE SOLUTION  ****  ',j,phij
+        STOP 4
+550   CONTINUE
+       ydeg     = yj * 180./pi
+       rlatu(j) = yj
+       IF(j.EQ.1) rlatu(j) = pis2
+c
+c    .....  calcul de  yprimu .....
+c
+
+       IF(j.EQ.1.OR.j.EQ.jjm +1) GO TO 1500
+       IF(yj.LT.yo)  THEN
+        psi = (yo -yj)/(pis2+yo)
+       ELSE
+        psi = (yj-yo)/(pis2-yo)
+       ENDIF
+
+      DO  it = nmax,0,-1
+      IF( yj.GE.yi(it))  GO TO 555
+      ENDDO
+555    CONTINUE
+       IF(it.EQ.nmax) THEN
+       PRINT *,' IT = nmax  Pbs ..',it,j
+       STOP 5
+       ENDIF
+       yppp=(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))*(yj-yi(it)) +
+     *               yprim(it)
+       yprimu(j) = pijjm/yppp
+c
+       PRINT 3000,j,ydeg,yprimu(j)
+1500   CONTINUE
+       rlatu(1)     =   pis2
+       rlatu(jjm+1) = - pis2
+c
+c     .............................................
+c
+c     .....   Calculs  pour  rlatv et yprimv  .....
+c     .............................................
+c
+
+      PRINT *,' ***************************** '
+      PRINT *,' ****  Calcul  de rlatv  ***** '
+      PRINT *,' ***************************** '
+      PRINT *,' *** j   rlatv  yprimv ****  '
+
+      DO 1600 j=1, jjm 
+
+      phij  = pis2+ pijjm*(1.-(FLOAT(j)+0.5))
+      yo1   = 0.
+      yj    = yo1
+
+      DO 1550 iter =1,300
+
+      DO 1520 it = nmax,0,-1
+      IF( yj.GE.yi(it))  GO TO 1530
+1520   CONTINUE
+c
+      it  = 0
+      yj  = yi(it)
+1530   CONTINUE
+       IF(it.EQ.nmax)  THEN
+       yint    = yf(nmax)
+       yprimin = yprim(nmax)
+      ELSE
+      yint= (yf(it+1)-yf(it))/(yi(it+1)-yi(it)) * ( yj-yi(it) )  +
+     +                          yf(it)
+      yprimin=(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))* ( yj-yi(it) ) +
+     +                          yprim(it)
+      ENDIF
+      yj = yj - (yint-phij)/yprimin
+
+      IF( ABS(yj-yo1).LE.eps ) GO TO 1560
+      yo1 = yj
+c
+1550   CONTINUE
+      PRINT *,'  ***  PAS DE SOLUTION  ***  ',j,phij
+1560   CONTINUE
+      ydeg    = yj * 180./pi
+      rlatv(j)= yj
+c
+c    .....  calcul de  yprimv .....
+c
+       IF(yj.LT.-pis2.OR.yj.GT.pis2)   STOP 6
+
+       IF(yj.LT.yo)  THEN
+        psi = (yo -yj)/(pis2+yo)
+       ELSE
+        psi = (yj-yo)/(pis2-yo)
+       ENDIF
+      DO  it = nmax,0,-1
+      IF( yj.GE.yi(it))   GO TO 1570
+      ENDDO
+1570    CONTINUE
+       IF(it.EQ.nmax) THEN
+       PRINT *,' IT = nmax  Pbs ..',it,j
+       STOP 7
+       ENDIF
+       yppp = (yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))*(yj-yi(it)) +
+     *                   yprim(it)
+       yprimv(j)= pijjm/ yppp
+c
+       PRINT 3000,j,ydeg,yprimv(j)
+
+1600  CONTINUE
+
+c
+c    ..................................................
+c
+      PRINT *,' ************************************ '
+      PRINT *,' ****  Calcul pour f( j + 0.25 ) **** '
+      PRINT *,' ************************************ '
+      PRINT *,' *** j  rlatu1  yprimu1 **** '
+c
+c    ..................................................
+c
+      DO 1800 j=1, jjm 
+
+      phij = pis2+ pijjm*( 1.- (FLOAT(j) + 0.25) )
+      yo1  = 0.
+      yj   = yo1
+C
+
+      DO 1620 iter = 1, 500
+
+      DO 1610 it = nmax,0,-1
+      IF( yj.GE.yi(it))  GO TO 1615
+1610   CONTINUE
+c
+      it = 0
+      yj = yi(it)
+1615   CONTINUE
+      IF(it.EQ.nmax)  THEN
+       yint    = yf(nmax)
+       yprimin = yprim(nmax)
+      ELSE
+      yint= (yf(it+1)-yf(it))/(yi(it+1)-yi(it))*(yj-yi(it))+
+     * yf(it)
+      yprimin=(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))*(yj-yi(it))+
+     * yprim(it)
+      ENDIF
+      yj = yj - (yint-phij)/yprimin
+c      IF( (- pis2-yj)*(yj- pis2 ).LT.0.)PRINT *,' Newton hors limites'
+
+      IF( ABS(yj-yo1).LE.eps ) GO TO 1625
+      yo1 = yj
+c
+1620   CONTINUE
+      PRINT *,' ***  PAS DE SOLUTION  ****  ',j,phij
+1625   CONTINUE
+      ydeg     = yj * 180./pi
+      rlatu1(j)= yj
+c
+c    .....  calcul de  yprimu1 .....
+c
+       IF( yj.LT.-pis2.OR.yj.GT.pis2 )  STOP 8
+c
+       IF(yj.LT.yo)  THEN
+        psi = (yo -yj)/(pis2+yo)
+       ELSE
+        psi = (yj-yo)/(pis2-yo)
+       ENDIF
+      DO  it = nmax,0,-1
+      IF( yj.GE.yi(it))   GO TO 1630
+      ENDDO
+1630    CONTINUE
+       IF(it.EQ.nmax) THEN
+       PRINT *,' IT = nmax  Pbs ..',it,j
+       STOP 9
+       ENDIF
+       yppp = (yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))*(yj-yi(it)) +
+     *          yprim(it)
+       yprimu1(j) = pijjm/yppp
+c
+       PRINT 3000,j,ydeg,yprimu1(j)
+
+1800  CONTINUE
+    
+c    ..............................................
+c
+      PRINT *,' ********************************** '
+      PRINT *,' **** Calcul pour f( j + 3/4  ) *** '
+      PRINT *,' ********************************** '
+      PRINT *,' *** j  rlatu2  yprimu2 ***  '
+c    ..............................................
+c
+      DO 1900 j=1, jjm 
+
+      phij = pis2+ pijjm*(1.-(FLOAT(j)+0.75))
+      yo1  = 0.
+      yj   = yo1
+
+      DO 1700 iter =1,500
+
+      DO 1680 it = nmax,0,-1
+      IF( yj.GE.yi(it))   GO TO 1690
+1680   CONTINUE
+      it  = 0
+      yj  = yi(it)
+1690   CONTINUE
+      IF(it.EQ.nmax)  THEN
+       yint     = yf(nmax)
+       yprimin = yprim(nmax)
+      ELSE
+      yint= (yf(it+1)-yf(it))/(yi(it+1)-yi(it)) * ( yj -yi(it) ) +
+     +                             yf(it)
+      yprimin=(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))* ( yj-yi(it) ) +
+     +                             yprim(it)
+      ENDIF
+      yj = yj - (yint-phij)/yprimin
+
+      IF( ABS(yj-yo1).LE.eps ) GO TO 1705
+      yo1 = yj
+c
+1700   CONTINUE
+      PRINT *,' PAS DE SOLUTION ',j,phij
+        STOP 10
+1705   CONTINUE
+      ydeg      = yj * 180./pi
+      rlatu2(j) = yj
+c
+c    .....  calcul de  yprimu2 .....
+c
+       IF(yj.LT.- pis2.OR.yj.GT.pis2)  STOP 11
+
+       IF(yj.LT.yo)  THEN
+        psi = (yo -yj)/(pis2+yo)
+       ELSE
+        psi = (yj-yo)/(pis2-yo)
+       ENDIF
+c
+       DO  it = nmax,0,-1
+       IF( yj.GE.yi(it))  GO TO 1710
+       ENDDO
+1710    CONTINUE
+       IF(it.EQ.nmax) THEN
+       PRINT *,' IT = nmax  Pbs ..',it,j
+        STOP 12
+       ENDIF
+      yppp =(yprim(it+1)-yprim(it))/(yi(it+1)-yi(it))* ( yj - yi(it) ) +
+     +                       yprim(it)
+       yprimu2(j) = pijjm/yppp
+c
+       PRINT 3000,j,ydeg,yprimu2(j)
+
+1900  CONTINUE
+c
+       PRINT *,'  *** TEST DE COHERENCE DANS  FXYP **** '
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         PRINT *,' 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
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        PRINT *,' rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        PRINT *,' rlatv > rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        PRINT *,' rlatv < rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        PRINT *,' rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       PRINT *,' ***  Les latitudes yprimu,yprimv,yprimu1,yprimu2 ',
+     * ' sont coherentes entre elles !  *** ' 
+
+c
+ 1     FORMAT( 3x,'Fxyhyp.  psi0  delta clat ',3f7.2)
+3000   FORMAT(2x,i4,2x,f8.2,f8.3)
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhyper.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhyper.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxyhyper.F	(revision 428)
@@ -0,0 +1,137 @@
+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)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+       REAL*8  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxysinus.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxysinus.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fxysinus.F	(revision 428)
@@ -0,0 +1,66 @@
+      SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+
+      IMPLICIT NONE
+c
+c     Calcul  des longitudes et des latitudes  pour une fonction f(x,y)
+c            avec y = Asin( j )  .
+c
+c     Auteur  :  P. Le Van
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+       INTEGER i,j
+
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+
+#include "fxy_sin.h"
+
+
+c    ......  calcul  des  latitudes  et de y'   .....
+c
+       DO j = 1, jjm + 1 
+          rlatu(j) = fy    ( FLOAT( j )        )
+         yprimu(j) = fyprim( FLOAT( j )        )
+       ENDDO
+
+
+       DO j = 1, jjm
+
+         rlatv(j)  = fy    ( FLOAT( j ) + 0.5  )
+         rlatu1(j) = fy    ( FLOAT( j ) + 0.25 ) 
+         rlatu2(j) = fy    ( FLOAT( j ) + 0.75 ) 
+
+        yprimv(j)  = fyprim( FLOAT( j ) + 0.5  ) 
+        yprimu1(j) = fyprim( FLOAT( j ) + 0.25 )
+        yprimu2(j) = fyprim( FLOAT( j ) + 0.75 )
+
+       ENDDO
+
+c
+c     .....  calcul   des  longitudes et de  x'   .....
+c
+       DO i = 1, iim + 1
+           rlonv(i)     = fx    (   FLOAT( i )          )
+           rlonu(i)     = fx    (   FLOAT( i ) + 0.5    )
+        rlonm025(i)     = fx    (   FLOAT( i ) - 0.25  )
+        rlonp025(i)     = fx    (   FLOAT( i ) + 0.25  )
+
+         xprimv  (i)    = fxprim (  FLOAT( i )          )
+         xprimu  (i)    = fxprim (  FLOAT( i ) + 0.5    )
+        xprimm025(i)    = fxprim (  FLOAT( i ) - 0.25   )
+        xprimp025(i)    = fxprim (  FLOAT( i ) + 0.25   )
+       ENDDO
+
+c
+       RETURN
+       END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fyhyp.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fyhyp.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/fyhyp.F	(revision 428)
@@ -0,0 +1,376 @@
+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
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzoom,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL*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
+
+       INTEGER i,j,it,ik,iter,jlat
+       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.
+       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 
+        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
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gcm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gcm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gcm.F	(revision 428)
@@ -0,0 +1,778 @@
+
+      PROGRAM gcm
+
+      USE IOIPSL
+
+      IMPLICIT NONE
+
+c      ......   Version  du 10/01/98    ..........
+
+c             avec  coordonnees  verticales hybrides 
+c   avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 )
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+c
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+c  ... Possibilite de choisir le shema 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-----------------------------------------------------------------------
+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"
+
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      SAVE  clesphy0
+
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d'1 jour
+      REAL zdtvr
+      INTEGER nbetatmoy, nbetatdem,nbetat
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                 ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL p (ip1jmp1,llmp1  )               ! pression aux interfac.des couches
+      REAL pks(ip1jmp1)                      ! exner au  sol
+      REAL pk(ip1jmp1,llm)                   ! exner au milieu des couches
+      REAL pkf(ip1jmp1,llm)                  ! exner filt.au milieu des couches
+      REAL masse(ip1jmp1,llm)                ! masse d'air
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL phi(ip1jmp1,llm)                  ! geopotentiel
+      REAL w(ip1jmp1,llm)                    ! vitesse verticale
+
+c variables dynamiques intermediaire pour le transport
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse
+
+c   variables dynamiques au pas -1
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1)
+      REAL massem1(ip1jmp1,llm)
+
+c   tendances dynamiques
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1)
+
+c   tendances de la dissipation
+      REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm)
+      REAL dhdis(ip1jmp1,llm)
+
+c   tendances physiques
+      REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm)
+      REAL dhfi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1)
+
+c   variables pour le fichier histoire
+      REAL dtav      ! intervalle de temps elementaire
+
+      REAL tppn(iim),tpps(iim),tpn,tps
+c
+      INTEGER iadv(nqmx) ! indice schema de transport pour le traceur iq
+
+      INTEGER itau,itaufinp1,iav
+
+      EXTERNAL caldyn, traceur
+      EXTERNAL dissip,geopot,iniconst,inifilr
+      EXTERNAL integrd,SCOPY
+      EXTERNAL iniav,writeav,writehist
+      EXTERNAL inigeom
+      EXTERNAL exner_hyb,addit
+      EXTERNAL defrun_new, test_period
+      REAL  SSUM
+      REAL time_0 , finvmaold(ip1jmp1,llm)
+
+      LOGICAL lafin
+      INTEGER ij,iq,l,numvanle,iapp_tracvl
+
+
+      INTEGER fluxid, fluxvid,fluxdid
+      integer histid, histvid, histaveid
+      real time_step, t_wrt, t_ops
+
+      REAL rdayvrai,rdaym_ini,rday_ecri
+      LOGICAL first
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+c+jld variables test conservation energie
+      REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm)
+C     Tendance de la temp. potentiel d (theta)/ d t due a la 
+C     tansformation d'energie cinetique en energie thermique
+C     cree par la dissipation
+      REAL dhecdt(ip1jmp1,llm)
+      REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm)
+      REAL      d_h_vcol, d_qt, d_qw, d_ql, d_ec
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/1/
+c-jld 
+
+      LOGICAL offline  ! Controle du stockage ds "fluxmass"
+      PARAMETER (offline=.false.)
+
+      character*80 dynhist_file, dynhistave_file
+      character*20 modname
+      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'
+      lafin    = .FALSE.
+      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
+c  ....  Choix  des shemas d'advection pour l'eau et les traceurs  ...
+c  ...................................................................
+c
+c     iadv = 1    shema  transport type "humidite specifique LMD"  
+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
+c                                , iq = 2  pour l'eau liquide
+c         et eventuellement      , iq = 3, nqmx pour les autres traceurs
+c
+c     iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+c
+      DO iq = 1, nqmx
+       iadv( iq ) = 3
+      ENDDO
+c
+       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
+       IF( iadv(iq).EQ.2 ) PRINT *,' Choix du shema  amont',' pour le'
+     * ,' traceur no ', iq
+       IF( iadv(iq).EQ.3 ) PRINT *,' Choix du shema  Van-Leer ',' pour'
+     * ,'le traceur no ', iq
+
+       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
+     * . '
+         CALL ABORT 
+       ENDIF
+      ENDDO
+c
+      first = .TRUE.
+      numvanle = nqmx + 1
+      DO  iq = 1, nqmx
+        IF((iadv(iq).EQ.3.OR.iadv(iq).EQ.4).AND.first ) THEN
+          numvanle = iq
+          first    = .FALSE.
+        ENDIF
+      ENDDO
+c
+      DO  iq = 1, nqmx
+      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 . '
+           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
+         STOP
+        ENDIF
+      ENDDO
+c
+
+      CALL dynetat0("start.nc",nqmx,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+
+
+c     OPEN( 99,file ='run.def',status='old',form='formatted')
+c      CALL defrun_new( 99, .TRUE. , clesphy0 )
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+c     CLOSE(99)
+
+c  on recalcule eventuellement le pas de temps
+
+      IF(MOD(day_step,iperiod).NE.0)
+     * STOP'Il faut choisir un nb de pas par jour multiple de iperiod'
+
+      IF(MOD(day_step,iphysiq).NE.0)
+     * STOP'Il faut choisir un nb de pas par jour multiple de iphysiq'
+
+      zdtvr    = daysec/FLOAT(day_step)
+        IF(dtvr.NE.zdtvr) THEN
+         PRINT*,'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr
+        ENDIF
+
+c  nombre d'etats dans les fichiers demarrage et histoire
+      nbetatdem = nday / iecri
+      nbetatmoy = nday / periodav + 1
+
+      dtvr = zdtvr
+      CALL iniconst
+      CALL inigeom
+
+      CALL inifilr
+c
+c   ......    P.Le Van    ( modif  le 29/04/97 )   .........  
+c
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+c+jld
+C     initialisation constantes thermo utilisees dans diagedyn
+      IF (ip_ebil.ge.1 ) THEN
+        CALL suphec
+      ENDIF 
+c-jld
+c
+
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+c
+
+c  numero de stockage pour les fichiers de redemarrage:
+
+c-----------------------------------------------------------------------
+c   temps de depart et de fin:
+c   --------------------------
+
+      itau = 0
+      iday = day_ini+itau/day_step
+      time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+         IF(time.GT.1.) THEN
+          time = time-1.
+          iday = iday+1
+         ENDIF
+      itaufin   = nday*day_step
+      itaufinp1 = itaufin +1
+
+      day_end = day_ini + nday
+      PRINT 300, itau,itaufin,day_ini,day_end
+
+      CALL dynredem0("restart.nc", day_end, phis, nqmx)
+
+      ecripar = .TRUE.
+
+      time_step = zdtvr
+      t_ops = iecri * daysec
+      t_wrt = iecri * daysec
+C      CALL inithist(dynhist_file,day_ref,annee_ref,time_step,
+c     .              t_ops, t_wrt, nqmx, histid, histvid)
+
+      t_ops = iperiod * time_step
+      t_wrt = periodav * daysec
+      CALL initdynav(dynhistave_file,day_ref,annee_ref,time_step,
+     .              t_ops, t_wrt, nqmx, histaveid)
+
+      dtav = iperiod*dtvr/daysec
+
+
+c   Quelques initialisations pour les traceurs
+      call initial0(ijp1llm*nqmx,dq)
+      istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+      istphy=istdyn/iphysiq
+
+c-----------------------------------------------------------------------
+c   Debut de l'integration temporelle:
+c   ----------------------------------
+
+   1  CONTINUE
+
+
+
+      if (ok_nudge) then
+        call nudge(itau,ucov,vcov,teta,masse,ps)
+      endif
+c
+c     IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+        CALL  test_period ( ucov,vcov,teta,q,p,phis )
+        PRINT *,' ----   Test_period apres continue   OK ! -----', itau
+c     ENDIF 
+c
+      CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 )
+      CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 )
+      CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 )
+      CALL SCOPY( ijp1llm,masse, 1, massem1, 1 )
+      CALL SCOPY( ip1jmp1, ps  , 1,   psm1 , 1 )
+
+      forward = .TRUE.
+      leapf   = .FALSE.
+      dt      =  dtvr
+
+c   ...    P.Le Van .26/04/94  ....
+
+      CALL SCOPY   ( ijp1llm,   masse, 1, finvmaold,     1 )
+      CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 )
+
+
+   2  CONTINUE
+
+c-----------------------------------------------------------------------
+
+c   date:
+c   -----
+
+
+c   gestion des appels de la physique et des dissipations:
+c   ------------------------------------------------------
+c
+c   ...    P.Le Van  ( 6/02/95 )  ....
+
+      apphys = .FALSE.
+      statcl = .FALSE.
+      conser = .FALSE.
+      apdiss = .FALSE.
+
+      IF( purmats ) THEN
+         IF( MOD(itau,iconser) .EQ.0.AND.  forward    ) conser = .TRUE.
+         IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE.
+         IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward 
+     $                              .AND.   physic    ) apphys = .TRUE.
+      ELSE
+         IF( MOD(itau   ,iconser) .EQ. 0              ) conser = .TRUE.
+         IF( MOD(itau+1,idissip)  .EQ. 0              ) apdiss = .TRUE.
+         IF( MOD(itau+1,iphysiq).EQ.0. AND. physic    ) apphys = .TRUE.
+      END IF
+
+c-----------------------------------------------------------------------
+c   calcul des tendances dynamiques:
+c   --------------------------------
+
+      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+c
+c
+      CALL caldyn 
+     $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+     $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time+iday-day_ini )
+
+c-----------------------------------------------------------------------
+c   calcul des tendances advection des traceurs (dont l'humidite)
+c   -------------------------------------------------------------
+
+      IF( forward. OR . leapf )  THEN
+c
+        DO 15  iq = 1, nqmx
+c
+         IF( iadv(iq).EQ.1.OR.iadv(iq).EQ.2 )  THEN
+           CALL traceur( iq,iadv,q,teta,pk,w, pbaru, pbarv, dq )
+
+         ELSE IF( iq.EQ. nqmx )   THEN
+c
+            iapp_tracvl = 5
+c
+cccc     iapp_tracvl est la frequence en pas du groupement des flux
+cccc      de masse pour  Van-Leer dans la routine  tracvl  .
+c
+            CALL vanleer(numvanle,iapp_tracvl,nqmx,q,pbaru,pbarv,
+     *                      p, masse, dq,  iadv(1), teta, pk     )
+c
+c                   ...  Modif  F.Codron  ....
+c
+         ENDIF
+c
+ 15     CONTINUE
+C
+         IF (offline) THEN
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+
+            CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+     .   time_step, itau)
+
+
+         ENDIF
+c
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+
+       CALL integrd ( iadv, 2,vcovm1,ucovm1,tetam1,psm1,massem1 ,
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
+     $              finvmaold                                    )
+
+c .P.Le Van (26/04/94  ajout de  finvpold dans l'appel d'integrd)
+c
+c-----------------------------------------------------------------------
+c   calcul des tendances physiques:
+c   -------------------------------
+c    ########   P.Le Van ( Modif le  6/02/95 )   ###########
+c
+       IF( purmats )  THEN
+          IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE.
+       ELSE
+          IF( itau+1. EQ. itaufin )              lafin = .TRUE.
+       ENDIF
+c
+c
+       IF( apphys )  THEN
+c
+c     .......   Ajout   P.Le Van ( 17/04/96 )   ...........
+c
+
+         CALL pression (  ip1jmp1, ap, bp, ps,  p      )
+         CALL exner_hyb(  ip1jmp1, ps, p,alpha,beta,pks, pk, pkf )
+
+           rdaym_ini  = itau * dtvr / daysec
+           rdayvrai   = rdaym_ini  + day_ini
+
+           IF ( ecritphy.LT.1. )  THEN
+             rday_ecri = rdaym_ini
+           ELSE
+             rday_ecri = NINT( rdayvrai )
+           ENDIF
+c
+
+c rajout debug
+c       lafin = .true.
+c+jld
+      IF (ip_ebil.ge.1 ) THEN 
+          ztit='bil dyn'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2),aire
+     s  , d_h_vcol , d_qt, d_qw, d_ql, d_ec)
+      ENDIF 
+c-jld
+        CALL calfis( nqmx, lafin ,rdayvrai,rday_ecri,time  ,
+     $                 ucov,vcov,teta,q,masse,ps,p,pk,phis,phi ,
+     $     du,dv,dteta,dq,w,clesphy0, dufi,dvfi,dhfi,dqfi,dpfi  )
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi( nqmx, dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dhfi , dqfi ,dpfi  )
+c
+c+jld
+      IF (ip_ebil.ge.1 ) THEN 
+          ztit='bil phys'
+          CALL diagedyn(ztit,2,1,1,dtphys
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2),aire
+     s  , d_h_vcol , d_qt, d_qw, d_ql, d_ec)
+      ENDIF 
+c-jld
+       ENDIF
+
+        CALL pression ( ip1jmp1, ap, bp, ps, p                  )
+        CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+
+c-----------------------------------------------------------------------
+c
+c
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+      IF(apdiss) THEN
+c+jld
+      IF (ip_ebil.ge.2 ) THEN 
+          ztit='avant dissip'
+          CALL diagedyn(ztit,2,2,2,dtvr
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2),aire
+     s  , d_h_vcol , d_qt, d_qw, d_ql, d_ec)
+      ENDIF 
+        CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+        CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin0  )
+c-jld
+
+         CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dhdis)
+
+         CALL addit( ijp1llm,ucov ,dudis,ucov )
+         CALL addit( ijmllm ,vcov ,dvdis,vcov )
+c+jld
+        CALL covcont  ( llm    , ucov    , vcov , ucont, vcont        )
+        CALL enercin ( vcov   , ucov  , vcont     , ucont  , ecin  )
+C
+C       On rajoute la tendance due a la transform. Ec -> E therm. cree
+C       lors de la dissipation
+        DO l  =  1, llm
+          DO    ij     = 1, ip1jmp1
+            dhecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l)
+            dhdis(ij,l) = dhdis(ij,l) + dhecdt(ij,l)
+          ENDDO
+        ENDDO
+c-jld
+         CALL addit( ijp1llm,teta ,dhdis,teta )
+c+jld
+c
+         IF (ip_ebil.ge.2 ) THEN 
+             ztit='apres dissip'
+             CALL diagedyn(ztit,2,2,2,dtdiss
+     e  , ucov    , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2),aire
+     s  , d_h_vcol , d_qt, d_qw, d_ql, d_ec)
+         ENDIF 
+c-jld
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+
+        DO l  =  1, llm
+          DO ij =  1,iim
+           tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+           tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+          ENDDO
+           tpn  = SSUM(iim,tppn,1)/apoln
+           tps  = SSUM(iim,tpps,1)/apols
+
+          DO ij = 1, iip1
+           teta(  ij    ,l) = tpn
+           teta(ij+ip1jm,l) = tps
+          ENDDO
+        ENDDO
+
+        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   ********************************************************************
+c   ********************************************************************
+c   .... fin de l'integration dynamique  et physique pour le pas itau ..
+c   ********************************************************************
+c   ********************************************************************
+
+c   preparation du pas d'integration suivant  ......
+
+      IF ( .NOT.purmats ) THEN
+c       ........................................................
+c       ..............  schema matsuno + leapfrog  ..............
+c       ........................................................
+
+            IF(forward. OR. leapf) THEN
+              itau= itau + 1
+              iday= day_ini+itau/day_step
+              time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+                IF(time.GT.1.) THEN
+                  time = time-1.
+                  iday = iday+1
+                ENDIF
+            ENDIF
+
+
+            IF( itau. EQ. itaufinp1 ) then  
+
+              abort_message = 'Simulation finished'
+              call abort_gcm(modname,abort_message,0)
+            ENDIF
+c-----------------------------------------------------------------------
+c   ecriture du fichier histoire moyenne:
+c   -------------------------------------
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+               CALL writedynav(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+cccIM cf. FH
+               call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   ecriture de la bande histoire:
+c   ------------------------------
+
+            IF( MOD(itau,iecri*day_step).EQ.0) THEN
+
+               nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi        )
+c       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+c     ,                          ucov,teta,phi,q,masse,ps,phis)
+
+
+            ENDIF
+
+            IF(itau.EQ.itaufin) THEN
+
+
+       PRINT *,' Appel test_period avant redem ', itau
+       CALL  test_period ( ucov,vcov,teta,q,p,phis )
+       CALL dynredem1("restart.nc",0.0,
+     .                     vcov,ucov,teta,q,nqmx,masse,ps)
+
+              CLOSE(99)
+            ENDIF
+
+c-----------------------------------------------------------------------
+c   gestion de l'integration temporelle:
+c   ------------------------------------
+
+            IF( MOD(itau,iperiod).EQ.0 )    THEN
+                    GO TO 1
+            ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN
+
+                   IF( forward )  THEN
+c      fin du pas forward et debut du pas backward
+
+                      forward = .FALSE.
+                        leapf = .FALSE.
+                           GO TO 2
+
+                   ELSE
+c      fin du pas backward et debut du premier pas leapfrog
+
+                        leapf =  .TRUE.
+                        dt  =  2.*dtvr
+                        GO TO 2
+                   END IF
+            ELSE
+
+c      ......   pas leapfrog  .....
+
+                 leapf = .TRUE.
+                 dt  = 2.*dtvr
+                 GO TO 2
+            END IF
+
+      ELSE
+
+c       ........................................................
+c       ..............       schema  matsuno        ...............
+c       ........................................................
+            IF( forward )  THEN
+
+             itau =  itau + 1
+             iday = day_ini+itau/day_step
+             time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0
+
+                  IF(time.GT.1.) THEN
+                   time = time-1.
+                   iday = iday+1
+                  ENDIF
+
+               forward =  .FALSE.
+               IF( itau. EQ. itaufinp1 ) then  
+                 abort_message = 'Simulation finished'
+                 call abort_gcm(modname,abort_message,0)
+               ENDIF
+               GO TO 2
+
+            ELSE
+
+            IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+               IF(itau.EQ.itaufin) THEN
+                  iav=1
+               ELSE
+                  iav=0
+               ENDIF
+               CALL writedynav(histaveid, nqmx, itau,vcov ,
+     ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+cccIM cf. FH
+               call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav,
+     ,           ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q)
+
+            ENDIF
+
+               IF(MOD(itau,iecri*day_step).EQ.0) THEN
+                  nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi       )
+c       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+c     ,                          ucov,teta,phi,q,masse,ps,phis)
+               ENDIF
+
+                 IF(itau.EQ.itaufin)
+     . CALL dynredem1("restart.nc",0.0,
+     .                     vcov,ucov,teta,q,nqmx,masse,ps)
+
+                 forward = .TRUE.
+                 GO TO  1
+
+            ENDIF
+
+      END IF
+
+ 300  FORMAT('1'/,15x,'run du pas',i7,2x,'au pas',i7,2x,  
+     . 'c''est a dire du jour',i7,3x,'au jour',i7//)
+
+      STOP
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/geopot.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/geopot.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/geopot.F	(revision 428)
@@ -0,0 +1,61 @@
+      SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    ....   calcul du geopotentiel aux milieux des couches    .....
+c    *******************************************************************
+c
+c     ....   l'integration se fait de bas en haut  ....
+c
+c     .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg ..
+c              phi               est un  argum. de sortie pour le s-pg .
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid
+      REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) ,
+     *       phi(ngrid,llm)
+
+
+c   Local:
+c   ------
+
+      INTEGER  l, ij
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+
+      DO   1  ij  = 1, ngrid
+      phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+   1  CONTINUE
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = 1,ngrid
+        phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l)  + teta(ij,l-1) ) 
+     *                              *   (  pk(ij,l-1) -  pk(ij,l)    )
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_dyn_fi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_dyn_fi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_dyn_fi.F	(revision 428)
@@ -0,0 +1,36 @@
+      SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER j,ifield,ig
+      EXTERNAL SCOPY
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim'
+c   traitement des poles
+      CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid)
+      CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid)
+
+c   traitement des point normaux
+      DO ifield=1,nfield
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_ecrit_fi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_ecrit_fi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_ecrit_fi.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/gr_fi_dyn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_fi_dyn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_fi_dyn.F	(revision 428)
@@ -0,0 +1,38 @@
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+      EXTERNAL SCOPY
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      DO ifield=1,nfield
+c   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+
+c   traitement des point normaux
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+	    pdyn(im,j,ifield)=pdyn(1,j,ifield)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_int_dyn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_int_dyn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_int_dyn.F	(revision 428)
@@ -0,0 +1,46 @@
+      subroutine gr_int_dyn(champin,champdyn,iim,jp1)
+      implicit none
+c=======================================================================
+c   passage d'un champ interpole a un champ sur grille scalaire
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER iim
+      integer ip1, jp1
+      REAL champin(iim, jp1)
+      REAL champdyn(iim+1, jp1)
+
+      INTEGER i, j
+      real polenord, polesud
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      ip1 = iim + 1
+      polenord = 0.
+      polesud = 0.
+      do i = 1, iim
+        polenord = polenord + champin (i, 1)
+        polesud = polesud + champin (i, jp1)
+      enddo
+      polenord = polenord / iim
+      polesud = polesud / iim
+      do j = 1, jp1
+        do i = 1, iim
+          if (j .eq. 1) then
+            champdyn(i, j) = polenord
+          else if (j .eq. jp1) then
+            champdyn(i, j) = polesud
+          else
+            champdyn(i, j) = champin (i, j)
+          endif
+        enddo
+        champdyn(ip1, j) = champdyn(1, j)
+      enddo
+
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_u_scal.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_u_scal.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_u_scal.F	(revision 428)
@@ -0,0 +1,57 @@
+      SUBROUTINE gr_u_scal(nx,x_u,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=ip1jmp1,2,-1
+            x_scal(ij,l)=
+     s      (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l))
+     s      /(aireu(ij)+aireu(ij-1))
+         ENDDO
+      ENDDO
+
+      CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_v_scal.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_v_scal.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gr_v_scal.F	(revision 428)
@@ -0,0 +1,61 @@
+      SUBROUTINE gr_v_scal(nx,x_v,x_scal)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER nx
+      REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx)
+
+c   Local:
+c   ------
+
+      INTEGER l,ij
+
+c-----------------------------------------------------------------------
+
+      DO l=1,nx
+         DO ij=iip2,ip1jm
+            x_scal(ij,l)=
+     s      (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l))
+     s      /(airev(ij-iip1)+airev(ij))
+         ENDDO
+         DO ij=1,iip1
+            x_scal(ij,l)=0.
+         ENDDO
+         DO ij=ip1jm+1,ip1jmp1
+            x_scal(ij,l)=0.
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grad.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grad.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grad.F	(revision 428)
@@ -0,0 +1,41 @@
+      SUBROUTINE  grad(klevel, pg,pgx,pgy )
+c
+c      P. Le Van
+c
+c    ******************************************************************
+c     .. calcul des composantes covariantes en x et y du gradient de g
+c
+c    ******************************************************************
+c             pg        est un   argument  d'entree pour le s-prog
+c       pgx  et  pgy    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+      INTEGER klevel
+      REAL  pg( ip1jmp1,klevel )
+      REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel )
+      INTEGER  l,ij
+c
+c
+      DO 6 l = 1,klevel
+c
+      DO 2  ij = 1, ip1jmp1 - 1
+      pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l )
+   2  CONTINUE
+c
+c    .... correction pour  pgx(ip1,j,l)  ....
+c    ...    pgx(iip1,j,l)= pgx(1,j,l)  ....
+CDIR$ IVDEP
+      DO 3  ij = iip1, ip1jmp1, iip1
+      pgx( ij,l ) = pgx( ij -iim,l )
+   3  CONTINUE
+c
+      DO 4 ij = 1,ip1jm
+      pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l )
+   4  CONTINUE
+c
+   6  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv.F	(revision 428)
@@ -0,0 +1,56 @@
+      SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c    Auteur :   P. Le Van
+c
+c   ***************************************************************
+c
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   ****************************************************************
+c    xcov , ycov et ld  sont des arguments  d'entree pour le s-prog
+c     gdx   et  gdy     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+
+      INTEGER klevel
+c
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL gdx( ip1jmp1,klevel ),   gdy( ip1jm,klevel )
+
+      REAL div(ip1jmp1,llm)
+
+      INTEGER l,ij,iter,ld
+c
+      EXTERNAL   SCOPY, diverg,  grad
+      EXTERNAL   filtreg
+c
+c
+      CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 )
+      CALL SCOPY( ip1jm*klevel,  ycov,1,gdy,1 )
+c
+      DO 10 iter = 1,ld
+c
+      CALL  diverg( klevel,  gdx , gdy, div          )
+      CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 )
+      CALL    grad( klevel,  div, gdx, gdy           )
+c
+      DO 5  l = 1, klevel
+      DO 3 ij = 1, ip1jmp1
+      gdx( ij,l ) = - gdx( ij,l ) * cdivu
+   3  CONTINUE
+      DO 4 ij = 1, ip1jm
+      gdy( ij,l ) = - gdy( ij,l ) * cdivu
+   4  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradiv2.F	(revision 428)
@@ -0,0 +1,77 @@
+      SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy )
+c
+c     P. Le Van
+c
+c   **********************************************************
+c                                ld
+c       calcul  de  (grad (div) )   du vect. v ....
+c
+c     xcov et ycov etant les composant.covariantes de v
+c   **********************************************************
+c     xcont , ycont et ld  sont des arguments  d'entree pour le s-prog
+c      gdx   et  gdy       sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comdissipn.h"
+c
+c     ........    variables en arguments      ........
+
+      INTEGER klevel
+      REAL  xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL   gdx( ip1jmp1,klevel ),  gdy( ip1jm,klevel )
+c
+c     ........       variables locales       .........
+c
+      REAL div(ip1jmp1,llm)
+      REAL signe, nugrads
+      INTEGER l,ij,iter,ld
+      
+c    ........................................................
+c
+      EXTERNAL   SCOPY, divergf, grad, laplacien_gam, filtreg
+c
+      CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 )
+      CALL SCOPY(   ip1jm * klevel, ycov, 1, gdy, 1 )
+c
+c
+      signe   = (-1.)**ld
+      nugrads = signe * cdivu
+c
+
+
+      CALL    divergf( klevel, gdx,   gdy , div )
+
+      IF( ld.GT.1 )   THEN
+
+        CALL laplacien ( klevel, div,  div     )
+
+c    ......  Iteration de l'operateur laplacien_gam   .......
+
+        DO iter = 1, ld -2
+         CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1,
+     *                       unsapolnga1, unsapolsga1,  div, div       )
+        ENDDO
+
+      ENDIF
+
+
+       CALL filtreg( div   , jjp1, klevel, 2, 1, .TRUE., 1 )
+       CALL  grad  ( klevel,  div,   gdx,  gdy             )
+
+c
+       DO   l = 1, klevel
+         DO  ij = 1, ip1jmp1
+          gdx( ij,l ) = gdx( ij,l ) * nugrads
+         ENDDO
+         DO  ij = 1, ip1jm
+          gdy( ij,l ) = gdy( ij,l ) * nugrads
+         ENDDO
+       ENDDO
+c
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradsdef.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradsdef.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/gradsdef.h	(revision 428)
@@ -0,0 +1,20 @@
+      integer nfmx,imx,jmx,lmx,nf,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=20,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,
+     s   imd,jmd,lmd,iid,jid,ifd,jfd,
+     s   unit,irec,nvar,ivar,nf,itime,nld,firsttime,
+     s   var,fichier,title,tvar
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_atob.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_atob.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_atob.F	(revision 428)
@@ -0,0 +1,968 @@
+      SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Aucune ponderation est consideree (voir grille_p)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+      REAL distans(2200*1100)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+c Calculer les limites des zones des nouveaux points
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c Determiner la zone sur laquelle chaque ancien point se trouve
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               number(ii,jj) = number(ii,jj) + 1.0
+               sortie(ii,jj) = sortie(ii,jj) + entree(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c Si aucun ancien point tombe sur une zone, c'est un probleme
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+      SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie)
+c=======================================================================
+c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead)
+c
+c Methode naive pour transformer un champ d'une grille fine a une
+c grille grossiere. Je considere que les nouveaux points occupent
+c une zone adjacente qui comprend un ou plusieurs anciens points
+c
+c Consideration de la distance des points (voir grille_m)
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X et Y pour depart
+c        xdata, ydata: coordonnees X et Y pour depart
+c        entree: champ d'entree a transformer
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        sortie: champ de sortie deja transforme
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(200),d(200)
+      REAL number(400,200)
+      INTEGER indx(400,200), indy(400,200)
+      REAL dist(400,200), distsom(400,200)
+c
+      IF (imar.GT.400 .OR. jmar.GT.200) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+      IF (imdep.GT.400 .OR. jmdep.GT.200) THEN
+         PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep
+         CALL ABORT
+      ENDIF
+c
+c calculer les bords a et b de la nouvelle grille
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+c
+c calculer les bords c et d de la nouvelle grille
+c
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+c
+c trouver les indices (indx,indy) de la nouvelle grille sur laquelle
+c un point de l'ancienne grille est tombe.
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               indx(i,j) = ii
+               indy(i,j) = jj
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c faire une verification
+c
+
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN
+            PRINT*, 'Probleme grave,i,j,indx,indy=',
+     .              i,j,indx(i,j),indy(i,j)
+            CALL abort
+         ENDIF
+      ENDDO
+      ENDDO
+
+c
+c calculer la distance des anciens points avec le nouveau point,
+c on prend ensuite une sorte d'inverse pour ponderation.
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         distsom(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2
+     .                     +(ydata(j)-y(indy(i,j)))**2 )
+         distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j))
+     .                                  + dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1.
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j))
+      ENDDO
+      ENDDO
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         number(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, imdep
+      DO j = 1, jmdep
+         sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j))
+     .                                 + entree(i,j) * dist(i,j)
+         number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j))
+     .                                 + dist(i,j)
+      ENDDO
+      ENDDO
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (number(i,j) .GT. 0.001) THEN
+         sortie(i,j) = sortie(i,j) / number(i,j)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+      SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief,
+     .                    imar, jmar, x, y, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique
+c                           un champ indicateur (masque) terre/ocean
+c                           terre:1; ocean:0
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL relief(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL num_tot(2200,1100), num_oce(2200,1100)
+c
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_oce(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+               num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+               IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) )
+     .             num_oce(ii,jj) = num_oce(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+c
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN
+              mask(i,j) = 0.
+           ELSE
+              mask(i,j) = 1.
+           ENDIF
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c
+c
+
+
+      SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree,
+     .                    imar, jmar, x, y, sortie, mask)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une
+c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur
+c fixe (0.001m).
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL sortie(imar,jmar), mask(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_tot(i,j) = 0.0
+         sortie(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              sortie(ii,jj)  = sortie(ii,jj) + LOG(entree(i,j))
+              num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+       IF (NINT(mask(i,j)).EQ.1) THEN
+         IF (num_tot(i,j) .GT. 0.0) THEN
+            sortie(i,j) = sortie(i,j) / num_tot(i,j)
+            sortie(i,j) = EXP(sortie(i,j))
+         ELSE
+            PRINT*, 'probleme,i,j=', i,j
+ccc            CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         sortie(i,j) = entree(i_proche,j_proche)
+         ENDIF
+       ELSE
+         sortie(i,j) = 0.001
+       ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+
+
+      SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01,
+     .                    imar, jmar, x, y, frac_ice)
+c=======================================================================
+c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la
+c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace
+c (entre 0 et 1) dans une grille plus grossiere.
+c
+c Methode naive (voir grille_m)
+C=======================================================================
+      IMPLICIT none
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL glace01(imdep,jmdep)
+c
+      INTEGER imar, jmar
+      REAL x(imar),y(jmar)
+      REAL frac_ice(imar,jmar)
+c
+      INTEGER i, j, ii, jj
+      REAL a(400),b(400),c(400),d(400)
+      REAL num_tot(400,400), num_ice(400,400)
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      IF (imar.GT.400 .OR. jmar.GT.400) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+c
+
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar-1
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar) = b(imar-1)
+      b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         num_ice(i,j) = 0.0
+         num_tot(i,j) = 0.0
+      ENDDO
+      ENDDO
+
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imar
+      DO jj = 1, jmar
+        DO i = 1, imdep
+         IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmdep
+          IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+             num_tot(ii,jj) = num_tot(ii,jj) + 1.0
+              IF (NINT(glace01(i,j)).EQ.1 ) 
+     .       num_ice(ii,jj) = num_ice(ii,jj) + 1.0
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+
+      DO i = 1, imar
+      DO j = 1, jmar
+         IF (num_tot(i,j) .GT. 0.001) THEN
+           IF (num_ice(i,j).GT.0.001) THEN
+            frac_ice(i,j) = num_ice(i,j) / num_tot(i,j)
+           ELSE
+              frac_ice(i,j) = 0.0
+           ENDIF
+         ELSE
+           PRINT*, 'probleme,i,j=', i,j
+ccc           CALL ABORT
+         CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imdep*jmdep,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imdep*jmdep
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imdep + 1
+         i_proche = ij_proche - (j_proche-1)*imdep
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN
+            frac_ice(i,j) = 1.0
+         ELSE
+            frac_ice(i,j) = 0.0
+         ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
+      SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief,
+     .                    immod, jmmod, xmod, ymod, rugs)
+c=======================================================================
+c Calculer la longueur de rugosite liee au relief en utilisant
+c l'ecart-type dans une maille de 1x1
+C=======================================================================
+      IMPLICIT none
+c
+#ifdef CRAY
+      INTEGER ISMIN
+#else
+      REAL zzmin
+#endif
+c
+      REAL amin, AMAX
+c
+      INTEGER imrel, jmrel
+      REAL xrel(imrel),yrel(jmrel)
+      REAL relief(imrel,jmrel)
+c
+      INTEGER immod, jmmod
+      REAL xmod(immod),ymod(jmmod)
+      REAL rugs(immod,jmmod)
+c
+      INTEGER imtmp, jmtmp
+      PARAMETER (imtmp=360,jmtmp=180)
+      REAL xtmp(imtmp), ytmp(jmtmp)
+      REAL*8 cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp)
+      REAL zzzz
+c
+      INTEGER i, j, ii, jj
+      REAL a(2200),b(2200),c(1100),d(1100)
+      REAL number(2200,1100)
+c
+      REAL distans(400*400)
+      INTEGER i_proche, j_proche, ij_proche
+c
+      IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN
+         PRINT*, 'immod ou jmmod trop grand', immod, jmmod
+         CALL ABORT
+      ENDIF
+c
+c Calculs intermediares:
+c
+      xtmp(1) = -180.0 + 360.0/FLOAT(imtmp) / 2.0
+      DO i = 2, imtmp
+         xtmp(i) = xtmp(i-1) + 360.0/FLOAT(imtmp)
+      ENDDO
+      DO i = 1, imtmp
+         xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+      ytmp(1) = -90.0 + 180.0/FLOAT(jmtmp) / 2.0
+      DO j = 2, jmtmp
+         ytmp(j) = ytmp(j-1) + 180.0/FLOAT(jmtmp)
+      ENDDO
+      DO j = 1, jmtmp
+         ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0)
+      ENDDO
+c
+      a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0
+      b(1) = (xtmp(1)+xtmp(2))/2.0
+      DO i = 2, imtmp-1
+         a(i) = b(i-1)
+         b(i) = (xtmp(i)+xtmp(i+1))/2.0
+      ENDDO
+      a(imtmp) = b(imtmp-1)
+      b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0
+
+      c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0
+      d(1) = (ytmp(1)+ytmp(2))/2.0
+      DO j = 2, jmtmp-1
+         c(j) = d(j-1)
+         d(j) = (ytmp(j)+ytmp(j+1))/2.0
+      ENDDO
+      c(jmtmp) = d(jmtmp-1)
+      d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0
+
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         number(i,j) = 0.0
+         cham1tmp(i,j) = 0.0
+         cham2tmp(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, imtmp
+      DO jj = 1, jmtmp
+        DO i = 1, imrel
+         IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmrel
+          IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j)
+              cham2tmp(ii,jj) = cham2tmp(ii,jj) 
+     .                              + relief(i,j)*relief(i,j)
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, imtmp
+      DO j = 1, jmtmp
+         IF (number(i,j) .GT. 0.001) THEN
+         cham1tmp(i,j) = cham1tmp(i,j) / number(i,j)
+         cham2tmp(i,j) = cham2tmp(i,j) / number(i,j)
+         zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2
+         if (zzzz .lt. 0.0) then
+           if (zzzz .gt. -7.5) then
+             zzzz = 0.0
+             print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0'
+           else
+              stop 'Pb rugsoro, zzzz <-7.5'
+           endif
+         endif
+         cham2tmp(i,j) = SQRT(zzzz)
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+         CALL ABORT
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = cham2tmp(1,1)
+      AMAX = cham2tmp(1,1)
+      DO j = 1, jmtmp
+      DO i = 1, imtmp
+         IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j)
+         IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type 1x1:', amin, AMAX
+c
+c
+c
+      a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0
+      b(1) = (xmod(1)+xmod(2))/2.0
+      DO i = 2, immod-1
+         a(i) = b(i-1)
+         b(i) = (xmod(i)+xmod(i+1))/2.0
+      ENDDO
+      a(immod) = b(immod-1)
+      b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0
+
+      c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0
+      d(1) = (ymod(1)+ymod(2))/2.0
+      DO j = 2, jmmod-1
+         c(j) = d(j-1)
+         d(j) = (ymod(j)+ymod(j+1))/2.0
+      ENDDO
+      c(jmmod) = d(jmmod-1)
+      d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         number(i,j) = 0.0
+         rugs(i,j) = 0.0
+      ENDDO
+      ENDDO
+c
+c
+c
+c  .....  Modif  P. Le Van ( 23/08/95 )  ....
+
+      DO ii = 1, immod
+      DO jj = 1, jmmod
+        DO i = 1, imtmp
+         IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR.
+     .     (   xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 )   )
+     .           THEN
+          DO j = 1, jmtmp
+          IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR.
+     .      (  ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 )   )
+     .           THEN
+              number(ii,jj) = number(ii,jj) + 1.0
+              rugs(ii,jj) = rugs(ii,jj)
+     .                       + LOG(MAX(0.001,cham2tmp(i,j)))
+          ENDIF
+          ENDDO
+         ENDIF
+        ENDDO
+      ENDDO
+      ENDDO
+c
+c
+      DO i = 1, immod
+      DO j = 1, jmmod
+         IF (number(i,j) .GT. 0.001) THEN
+         rugs(i,j) = rugs(i,j) / number(i,j)
+         rugs(i,j) = EXP(rugs(i,j))
+         ELSE
+         PRINT*, 'probleme,i,j=', i,j
+ccc         CALL ABORT
+         CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans)
+#ifdef CRAY
+         ij_proche = ISMIN(imtmp*jmtmp,distans,1)
+#else
+         ij_proche = 1
+         zzmin = distans(ij_proche)
+         DO ii = 2, imtmp*jmtmp
+            IF (distans(ii).LT.zzmin) THEN
+               zzmin = distans(ii)
+               ij_proche = ii
+            ENDIF
+         ENDDO
+#endif
+         j_proche = (ij_proche-1)/imtmp + 1
+         i_proche = ij_proche - (j_proche-1)*imtmp
+         PRINT*, "solution:", ij_proche, i_proche, j_proche
+         rugs(i,j) = LOG(MAX(0.001,cham2tmp(i_proche,j_proche)))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Ecart-type du modele:', amin, AMAX
+c
+      DO j = 1, jmmod
+      DO i = 1, immod
+         rugs(i,j) = rugs(i,j) / AMAX * 20.0
+      ENDDO
+      ENDDO
+c
+      amin = rugs(1,1)
+      AMAX = rugs(1,1)
+      DO j = 1, jmmod
+      DO i = 1, immod
+         IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j)
+         IF (rugs(i,j).LT.amin) amin = rugs(i,j)
+      ENDDO
+      ENDDO
+      PRINT*, 'Longueur de rugosite du modele:', amin, AMAX
+c
+      RETURN
+      END
+c
+      SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance)
+c
+c Auteur: Laurent Li (le 30 decembre 1996)
+c
+c Ce programme calcule la distance minimale (selon le grand cercle)
+c entre deux points sur la terre
+c
+c Input:
+      INTEGER im, jm ! dimensions
+      REAL rf_lon ! longitude du point de reference (degres)
+      REAL rf_lat ! latitude du point de reference (degres)
+      REAL rlon(im), rlat(jm) ! longitude et latitude des points
+c
+c Output:
+      REAL distance(im,jm) ! distances en metre
+c
+      REAL rlon1, rlat1
+      REAL rlon2, rlat2
+      REAL dist
+      REAL pa, pb, p, pi
+c
+      REAL radius
+      PARAMETER (radius=6371229.)
+c
+      pi = 4.0 * ATAN(1.0)
+c
+      DO 9999 j = 1, jm
+      DO 9999 i = 1, im
+c
+      rlon1=rf_lon
+      rlat1=rf_lat
+      rlon2=rlon(i)
+      rlat2=rlat(j)
+      pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a
+      pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b
+      p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens)
+c
+      dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p))
+      dist = radius * dist
+      distance(i,j) = dist
+c
+ 9999 CONTINUE
+c
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_noro.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_noro.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grid_noro.F	(revision 428)
@@ -0,0 +1,516 @@
+c
+c $Header$
+c
+      SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata,
+     .             imar, jmar, x, y,
+     .             zphi,zmea,zstd,zsig,zgam,zthe,
+     .             zpic,zval,mask)
+c=======================================================================
+c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead)
+c
+c      Compute the Parameters of the SSO scheme as described in
+c      LOTT & MILLER (1997) and LOTT(1999).
+c      Target points are on a rectangular grid:
+c      iim+1 latitudes including North and South Poles;
+c      jjm+1 longitudes, with periodicity jjm+1=1.
+c      aux poles.  At the poles the fields value is repeated
+c      jjm+1 time.
+c      The parameters a,b,c,d represent the limite of the target
+c      gridpoint region. The means over this region are calculated
+c      from USN data, ponderated by a weight proportional to the 
+c      surface occupated by the data inside the model gridpoint area.
+c      In most circumstances, this weight is the ratio between the
+c      surface of the USN gridpoint area and the surface of the
+c      model gridpoint area. 
+c
+c           (c)
+c        ----d-----
+c        | . . . .|
+c        |        |
+c     (b)a . * . .b(a)
+c        |        |
+c        | . . . .|
+c        ----c-----
+c           (d)
+C=======================================================================
+c INPUT:
+c        imdep, jmdep: dimensions X and Y input field
+c        xdata, ydata: coordinates X and Y input field
+c        zdata: Input field
+c        In this version it is assumed that the entry data come from
+c        the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080.
+c OUTPUT:
+c        imar, jmar: dimensions X and Y Output field
+c        x, y: ccordinates  X and Y Output field.
+c             zmea:  Mean orographie   
+c             zstd:  Standard deviation
+c             zsig:  Slope
+c             zgam:  Anisotropy
+c             zthe:  Orientation of the small axis
+c             zpic:  Maximum altitude
+c             zval:  Minimum altitude
+C=======================================================================
+      IMPLICIT INTEGER (I,J)
+      IMPLICIT REAL(X,Z) 
+      
+	  parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5)
+#include "dimensions.h"
+	  REAL xusn(iusn+2*iext),yusn(jusn+2)	
+      REAL zusn(iusn+2*iext,jusn+2)
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL zdata(imdep,jmdep)
+c
+      INTEGER imar, jmar
+  
+C INTERMEDIATE FIELDS  (CORRELATIONS OF OROGRAPHY GRADIENT)
+
+      REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1)
+      REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1)
+      REAL weight(iim+1,jjm+1)
+
+C CORRELATIONS OF USN OROGRAPHY GRADIENTS
+
+      REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2)
+      REAL zxtzyusn(iusn+2*iext,jusn+2)
+      REAL x(imar+1),y(jmar),zphi(imar+1,jmar)
+      REAL zmea(imar+1,jmar),zstd(imar+1,jmar)
+      REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
+      REAL zpic(imar+1,jmar),zval(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
+      REAL a(2200),b(2200),c(1100),d(1100)
+      logical masque_lu
+c
+      print *,' parametres de l orographie a l echelle sous maille' 
+      xpi=acos(-1.)
+      rad    = 6 371 229.
+      zdeltay=2.*xpi/float(jusn)*rad
+c
+c utilise-t'on un masque lu?
+c
+      masque_lu = .true.
+      if (maxval(mask) == -99999 .and. minval(mask) == -99999) then
+        masque_lu= .false.
+        masque = 0.0
+      endif
+      write(*,*)'Masque lu', masque_lu
+c
+c  quelques tests de dimensions:
+c    
+c
+      if(iim.ne.imar) STOP 'Problem dim. x'
+      if(jjm.ne.jmar-1) STOP 'Problem dim. y'
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar or jmar too big', imar, jmar
+         CALL ABORT
+      ENDIF
+
+      IF(imdep.ne.iusn.or.jmdep.ne.jusn)then
+         print *,' imdep or jmdep bad dimensions:',imdep,jmdep
+         call abort
+      ENDIF
+
+      IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN
+        print *,' imar or jmar bad dimensions:',imar,jmar
+        call abort
+      ENDIF
+
+
+c      print *,'xdata:',xdata
+c      print *,'ydata:',ydata
+c      print *,'x:',x
+c      print *,'y:',y
+c
+C  EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT
+C  BOUNDARIES:
+c
+      DO j=1,jusn
+        yusn(j+1)=ydata(j)
+      DO i=1,iusn
+        zusn(i+iext,j+1)=zdata(i,j)
+        xusn(i+iext)=xdata(i)
+      ENDDO
+      DO i=1,iext
+        zusn(i,j+1)=zdata(iusn-iext+i,j)
+        xusn(i)=xdata(iusn-iext+i)-2.*xpi
+        zusn(iusn+iext+i,j+1)=zdata(i,j)
+        xusn(iusn+iext+i)=xdata(i)+2.*xpi
+      ENDDO
+      ENDDO
+
+        yusn(1)=ydata(1)+(ydata(1)-ydata(2))
+        yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1))
+       DO i=1,iusn/2+iext
+        zusn(i,1)=zusn(i+iusn/2,2)
+        zusn(i+iusn/2+iext,1)=zusn(i,2)
+        zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1)
+        zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1)
+       ENDDO
+c  
+c COMPUTE LIMITS OF MODEL GRIDPOINT AREA
+C     ( REGULAR GRID)
+c
+      a(1) = x(1) - (x(2)-x(1))/2.0
+      b(1) = (x(1)+x(2))/2.0
+      DO i = 2, imar
+         a(i) = b(i-1)
+         b(i) = (x(i)+x(i+1))/2.0
+      ENDDO
+      a(imar+1) = b(imar)
+      b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0
+
+      c(1) = y(1) - (y(2)-y(1))/2.0
+      d(1) = (y(1)+y(2))/2.0
+      DO j = 2, jmar-1
+         c(j) = d(j-1)
+         d(j) = (y(j)+y(j+1))/2.0
+      ENDDO
+      c(jmar) = d(jmar-1)
+      d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0
+c
+c  initialisations:
+c
+      DO i = 1, imar+1
+      DO j = 1, jmar
+         weight(i,j) = 0.0
+         zxtzx(i,j)  = 0.0
+         zytzy(i,j)  = 0.0
+         zxtzy(i,j)  = 0.0
+         ztz(i,j)    = 0.0
+         zmea(i,j)   = 0.0
+         zpic(i,j)  =-1.E+10
+         zval(i,j)  = 1.E+10
+      ENDDO
+      ENDDO
+c
+c  COMPUTE SLOPES CORRELATIONS ON USN GRID
+c
+         DO j = 1,jusn+2 
+         DO i = 1, iusn+2*iext
+            zytzyusn(i,j)=0.0
+            zxtzxusn(i,j)=0.0
+            zxtzyusn(i,j)=0.0
+         ENDDO
+         ENDDO
+
+
+         DO j = 2,jusn+1 
+            zdeltax=zdeltay*cos(yusn(j))
+         DO i = 2, iusn+2*iext-1
+            zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2
+            zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2
+            zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay
+     *                   *(zusn(i+1,j)-zusn(i-1,j))/zdeltax
+         ENDDO
+         ENDDO
+c
+c  SUMMATION OVER GRIDPOINT AREA
+c 
+      zleny=xpi/float(jusn)*rad
+      xincr=xpi/2./float(jusn)
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+       num_tot(ii,jj)=0.
+       num_lan(ii,jj)=0.
+c        PRINT *,' iteration ii jj:',ii,jj
+         DO j = 2,jusn+1 
+c         DO j = 3,jusn 
+            zlenx=zleny*cos(yusn(j))
+            zdeltax=zdeltay*cos(yusn(j))
+            zbordnor=(c(jj)-yusn(j)+xincr)*rad
+            zbordsud=(yusn(j)-d(jj)+xincr)*rad
+            weighy=AMAX1(0.,
+     *             amin1(zbordnor,zbordsud,zleny))
+         IF(weighy.ne.0)THEN
+         DO i = 2, iusn+2*iext-1
+            zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j))
+            zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j))
+            weighx=AMAX1(0.,
+     *             amin1(zbordest,zbordoue,zlenx))
+            IF(weighx.ne.0)THEN
+            num_tot(ii,jj)=num_tot(ii,jj)+1.0
+            if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0
+            weight(ii,jj)=weight(ii,jj)+weighx*weighy
+            zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy
+            zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy
+            zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy
+            ztz(ii,jj)  =ztz(ii,jj)  +zusn(i,j)*zusn(i,j)*weighx*weighy
+c mean
+            zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy
+c peacks
+            zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j))
+c valleys
+            zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j))
+            ENDIF
+         ENDDO
+         ENDIF
+         ENDDO
+       ENDDO
+       ENDDO
+c
+c  COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND
+C  LOTT (1999) SSO SCHEME.
+c
+      zllmmea=0.
+      zllmstd=0.
+      zllmsig=0.
+      zllmgam=0.
+      zllmpic=0.
+      zllmval=0.
+      zllmthe=0.
+      zminthe=0.
+c     print 100,' '
+c100  format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') 
+       DO ii = 1, imar+1
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Mask
+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
+             if (.not. masque_lu) then
+               mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj)
+             endif
+c  Mean Orography:
+           zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj)
+           zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj)
+           zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj)
+           zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj)
+           ztz(ii,jj)  =ztz(ii,jj)/weight(ii,jj)
+c  Standard deviation:
+           zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2))
+         ELSE
+            PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+       ENDDO
+       ENDDO
+
+C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES:
+
+       DO ii = 1, imar+1
+         zxtzx(ii,1)=zxtzx(ii,2)
+         zxtzx(ii,jmar)=zxtzx(ii,jmar-1)
+         zxtzy(ii,1)=zxtzy(ii,2)
+         zxtzy(ii,jmar)=zxtzy(ii,jmar-1)
+         zytzy(ii,1)=zytzy(ii,2)
+         zytzy(ii,jmar)=zytzy(ii,jmar-1)
+       ENDDO
+
+C  FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME.
+
+C  FIRST FILTER, MOVING AVERAGE OVER 9 POINTS.
+
+       CALL MVA9(zmea,iim+1,jjm+1)
+       CALL MVA9(zstd,iim+1,jjm+1)
+       CALL MVA9(zpic,iim+1,jjm+1)
+       CALL MVA9(zval,iim+1,jjm+1)
+       CALL MVA9(zxtzx,iim+1,jjm+1)
+       CALL MVA9(zxtzy,iim+1,jjm+1) 
+       CALL MVA9(zytzy,iim+1,jjm+1)
+C$$$   Masque prenant en compte maximum de terre
+C$$$  On seuil a 10% de terre de terre car en dessous les parametres de surface n'on
+C$$$ pas de sens (PB)
+       mask_tmp= 0.0
+       WHERE(mask .GE. 0.1) mask_tmp = 1.
+
+       DO ii = 1, imar
+       DO jj = 1, jmar
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Coefficients K, L et M:
+           xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2.
+           xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2.
+           xm=zxtzy(ii,jj)
+           xp=xk-sqrt(xl**2+xm**2)
+           xq=xk+sqrt(xl**2+xm**2)
+           xw=1.e-8
+           if(xp.le.xw) xp=0.
+           if(xq.le.xw) xq=xw
+           if(abs(xm).le.xw) xm=xw*sign(1.,xm)
+c slope: 
+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_tmp(ii,jj)
+c angle theta:
+           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),
+c    *           zthe(ii,jj)
+c101  format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1)     
+         ELSE
+c           PRINT*, 'probleme,ii,jj=', ii,jj
+         ENDIF
+      zllmmea=AMAX1(zmea(ii,jj),zllmmea)
+      zllmstd=AMAX1(zstd(ii,jj),zllmstd)
+      zllmsig=AMAX1(zsig(ii,jj),zllmsig)
+      zllmgam=AMAX1(zgam(ii,jj),zllmgam)
+      zllmthe=AMAX1(zthe(ii,jj),zllmthe)
+      zminthe=amin1(zthe(ii,jj),zminthe)
+      zllmpic=AMAX1(zpic(ii,jj),zllmpic)
+      zllmval=AMAX1(zval(ii,jj),zllmval)
+       ENDDO
+       ENDDO
+      print *,'  MEAN ORO:',zllmmea
+      print *,'  ST. DEV.:',zllmstd
+      print *,'  PENTE:',zllmsig
+      print *,' ANISOTROP:',zllmgam
+      print *,'  ANGLE:',zminthe,zllmthe	
+      print *,'  pic:',zllmpic
+      print *,'  val:',zllmval
+      
+C
+c gamma and theta a 1. and 0. at poles
+c
+      DO jj=1,jmar
+      zmea(imar+1,jj)=zmea(1,jj)
+      zphi(imar+1,jj)=zphi(1,jj)
+      zpic(imar+1,jj)=zpic(1,jj)
+      zval(imar+1,jj)=zval(1,jj)
+      zstd(imar+1,jj)=zstd(1,jj)
+      zsig(imar+1,jj)=zsig(1,jj)
+      zgam(imar+1,jj)=zgam(1,jj)
+      zthe(imar+1,jj)=zthe(1,jj)
+      ENDDO
+
+
+      zmeanor=0.0
+      zmeasud=0.0
+      zstdnor=0.0
+      zstdsud=0.0
+      zsignor=0.0
+      zsigsud=0.0
+      zweinor=0.0
+      zweisud=0.0
+      zpicnor=0.0
+      zpicsud=0.0                                   
+      zvalnor=0.0
+      zvalsud=0.0 
+
+      DO ii=1,imar
+      zweinor=zweinor+              weight(ii,   1)
+      zweisud=zweisud+              weight(ii,jmar)
+      zmeanor=zmeanor+zmea(ii,   1)*weight(ii,   1)
+      zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar)
+      zstdnor=zstdnor+zstd(ii,   1)*weight(ii,   1)
+      zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar)
+      zsignor=zsignor+zsig(ii,   1)*weight(ii,   1)
+      zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar)
+      zpicnor=zpicnor+zpic(ii,   1)*weight(ii,   1)
+      zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar)
+      zvalnor=zvalnor+zval(ii,   1)*weight(ii,   1)
+      zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/zweisud
+      zphi(ii,   1)=zmeanor/zweinor
+      zphi(ii,jmar)=zmeasud/zweisud
+      zpic(ii,   1)=zpicnor/zweinor
+      zpic(ii,jmar)=zpicsud/zweisud
+      zval(ii,   1)=zvalnor/zweinor
+      zval(ii,jmar)=zvalsud/zweisud
+      zstd(ii,   1)=zstdnor/zweinor
+      zstd(ii,jmar)=zstdsud/zweisud
+      zsig(ii,   1)=zsignor/zweinor
+      zsig(ii,jmar)=zsigsud/zweisud
+      zgam(ii,   1)=1.
+      zgam(ii,jmar)=1.
+      zthe(ii,   1)=0.
+      zthe(ii,jmar)=0.
+      ENDDO
+
+      RETURN
+      END
+
+      SUBROUTINE MVA9(X,IMAR,JMAR)
+
+C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+
+      PARAMETER (ISMo=300,JSMo=200)
+      REAL X(IMAR,JMAR),XF(ISMo,JSMo)
+      real WEIGHTpb(-1:1,-1:1)
+
+      if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)'
+      if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)'
+      
+      SUM=0.
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
+          SUM=SUM+WEIGHTpb(IS,JS)
+        ENDDO
+      ENDDO
+      
+c     WRITE(*,*) 'MVA9 ', IMAR, JMAR
+c     WRITE(*,*) 'MVA9 ', WEIGHTpb
+c     WRITE(*,*) 'MVA9 SUM ', SUM
+      DO IS=-1,1
+        DO JS=-1,1
+          WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        DO I=2,IMAR-1
+          XF(I,J)=0.
+          DO IS=-1,1
+            DO JS=-1,1
+              XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS)
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+        XF(1,J)=0.
+        IS=IMAR-1
+        DO JS=-1,1 
+          XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS)
+        ENDDO
+        DO IS=0,1 
+          DO JS=-1,1 
+            XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS)
+          ENDDO
+        ENDDO
+        XF(IMAR,J)=XF(1,J)
+      ENDDO
+
+      DO I=1,IMAR
+        XF(I,1)=XF(I,2)
+        XF(I,JMAR)=XF(I,JMAR-1)
+      ENDDO
+
+      DO I=1,IMAR
+        DO J=1,JMAR
+          X(I,J)=XF(I,J)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
+
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grilles_gcm_netcdf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grilles_gcm_netcdf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/grilles_gcm_netcdf.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/groupe.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/groupe.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/groupe.F	(revision 428)
@@ -0,0 +1,94 @@
+      subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      implicit none
+
+c   sous-programme servant a fitlrer les champs de flux de masse aux
+c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
+c   et a mesure qu'on se rapproche du pole.
+c
+c   en entree: pext, pbaru et pbarv
+c
+c   en sortie:  pbarum,pbarvm et wm.
+c
+c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
+c   pas besoin de w en entree.
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "comvert.h"
+
+      integer ngroup
+      parameter (ngroup=3)
+
+
+      real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm)
+      real pext(iip1,jjp1,llm)
+
+      real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm)
+      real wm(iip1,jjp1,llm)
+
+      real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm)
+
+      real uu
+
+      integer i,j,l
+
+      logical firstcall
+      save firstcall
+
+      data firstcall/.true./
+
+      if (firstcall) then
+         if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point'
+         firstcall=.false.
+      endif
+
+c   Champs 1D
+
+      call convflu(pbaru,pbarv,llm,zconvm)
+
+c
+      call scopy(ijp1llm,zconvm,1,zconvmm,1)
+      call scopy(ijmllm,pbarv,1,pbarvm,1)
+
+c
+      call groupeun(jjp1,llm,zconvmm)
+      call groupeun(jjm,llm,pbarvm)
+
+c   Champs 3D
+
+      do l=1,llm
+         do j=2,jjm
+            uu=pbaru(iim,j,l)
+            do i=1,iim
+               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
+               pbarum(i,j,l)=uu
+c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
+c    *                      yflu(i,j,l)-yflu(i,j-1,l)
+            enddo
+            pbarum(iip1,j,l)=pbarum(1,j,l)
+         enddo
+      enddo
+
+c    integration de la convergence de masse de haut  en bas ......
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+               zconvmm(i,j,l)=zconvmm(i,j,l)
+            enddo
+         enddo
+      enddo
+      do  l = llm-1,1,-1
+          do j=1,jjp1
+             do i=1,iip1
+                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
+             enddo
+          enddo
+      enddo
+
+      CALL vitvert(zconvmm,wm)
+
+      return
+      end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/groupeun.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/groupeun.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/groupeun.F	(revision 428)
@@ -0,0 +1,57 @@
+      subroutine groupeun(jjmax,llmax,q)
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      integer jjmax,llmax
+      real q(iip1,jjmax,llmax)
+
+      integer ngroup
+      parameter (ngroup=3)
+
+      real airen,airecn,qn
+      real aires,airecs,qs
+
+      integer i,j,l,ig,j1,j2,i0,jd
+
+Champs 3D
+      jd=jjp1-jjmax
+      do l=1,llm
+      j1=1+jd
+      j2=2
+      do ig=1,ngroup
+         do j=j1-jd,j2-jd
+c           print*,'groupe ',ig,'  j= ',j,2**(ngroup-ig+1),'pts groupes'
+            do i0=1,iim,2**(ngroup-ig+1)
+               airen=0.
+               airecn=0.
+               qn=0.
+               aires=0.
+               airecs=0.
+               qs=0.
+               do i=i0,i0+2**(ngroup-ig+1)-1
+                  airen=airen+aire(i,j)
+                  aires=aires+aire(i,jjp1-j+1)
+                  qn=qn+q(i,j,l)
+                  qs=qs+q(i,jjp1-j+1-jd,l)
+               enddo
+               airecn=0.
+               airecs=0.
+               do i=i0,i0+2**(ngroup-ig+1)-1
+                  q(i,j,l)=qn*aire(i,j)/airen
+                  q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires
+               enddo
+            enddo
+            q(iip1,j,l)=q(1,j,l)
+            q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
+         enddo
+         j1=j2+1
+         j2=j2+2**ig
+      enddo
+      enddo
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/heavyside.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/heavyside.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/heavyside.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/iniav.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniav.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniav.F	(revision 428)
@@ -0,0 +1,235 @@
+      SUBROUTINE iniav(fichnom,pday0,pyear0,pfrac0,pperiod,phis,nq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   pday0    jour de reference pour le stockage
+c   pfrac0   decalage du debut du stockage par rapport a pday0 (en jour)
+c   pperiod  period de stockage en secondes
+c   phis     geopotentiel au sol
+c   
+c   initialisation de l'ecriture des moyennes temporelles.
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comav.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom.h"
+
+      REAL pperiod
+
+      INTEGER*4 pday0,pyear0
+      REAL pfrac0
+      CHARACTER*(*) fichnom
+      REAL phis(ip1jmp1)
+c
+      CHARACTER str3*3
+c
+      INTEGER nq
+      INTEGER ierr, nid, nvarid, iq
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_s, idim_sig
+      INTEGER idim_tim
+      INTEGER dims2(2), dims3(3), dims4(4)
+
+      period_av=pperiod
+      time0_av=pfrac0
+c
+      ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+         WRITE(6,*)" Pb d ouverture du fichier "//fichnom
+         WRITE(6,*)' ierr = ', ierr
+         CALL ABORT
+      ENDIF
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 32,
+     .                       "Fichier moyen histoire dynamique")
+c
+c Definir les dimensions du fichiers:
+c
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s)
+      ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig)
+      ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid)
+      ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid)
+      ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid)
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid)
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+      ierr = NF_REDEF (nid)
+ccc      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid)
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c
+c Geopentiel au sol:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+ccc      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+c Definir les variables pour pouvoir les enregistrer plus tard:
+c
+      ierr = NF_REDEF (nid) ! entrer dans le mode de definition
+c
+ccc      ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid)
+      ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "iniav: Erreur pour definir <temps>"
+         CALL abort
+      ENDIF
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+ccc      ierr = NF_DEF_VAR (nid,"vitu",NF_DOUBLE,4,dims4,nvarid)
+      ierr = NF_DEF_VAR (nid,"vitu",NF_FLOAT,4,dims4,nvarid)
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatv
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+ccc      ierr = NF_DEF_VAR (nid,"vitv",NF_DOUBLE,4,dims4,nvarid)
+      ierr = NF_DEF_VAR (nid,"vitv",NF_FLOAT,4,dims4,nvarid)
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+ccc      ierr = NF_DEF_VAR (nid,"temp",NF_DOUBLE,4,dims4,nvarid)
+      ierr = NF_DEF_VAR (nid,"temp",NF_FLOAT,4,dims4,nvarid)
+c
+      dims4(1) = idim_rlonv
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_s
+      dims4(4) = idim_tim
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF (iq.GT.99) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ELSE
+         str3(1:1)='q'
+         WRITE(str3(2:3),'(i2.2)') iq
+ccc         ierr = NF_DEF_VAR (nid,str3,NF_DOUBLE,4,dims4,nvarid)
+         ierr = NF_DEF_VAR (nid,str3,NF_FLOAT,4,dims4,nvarid)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      dims3(1) = idim_rlonv
+      dims3(2) = idim_rlatu
+      dims3(3) = idim_tim
+ccc      ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid)
+      ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+      ierr = NF_CLOSE(nid) ! fermer le fichier
+
+      PRINT*,'le fichier hist.moy stoke les variables toutes'
+      PRINT*,'les ',period_av,'s'
+      PRINT*,'A partir du jour de reference day0'
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inicons0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inicons0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inicons0.F	(revision 428)
@@ -0,0 +1,53 @@
+      SUBROUTINE inicons0
+      IMPLICIT NONE
+c
+c  P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+#include "comdissnew.h"
+
+
+c
+c
+      EXTERNAL disvert0
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+      r       = cpp * kappa
+
+      PRINT*,' Cp R  kappa ',  cpp, r , kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniconst.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniconst.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniconst.F	(revision 428)
@@ -0,0 +1,55 @@
+      SUBROUTINE iniconst
+
+      IMPLICIT NONE
+c
+c      P. Le Van
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "temps.h"
+#include "control.h"
+#include "comvert.h"
+
+
+c
+c
+      EXTERNAL disvert
+c
+c-----------------------------------------------------------------------
+c   dimension des boucles:
+c   ----------------------
+
+      im      = iim
+      jm      = jjm
+      lllm    = llm
+      imp1    = iim 
+      jmp1    = jjm + 1
+      lllmm1  = llm - 1
+      lllmp1  = llm + 1
+
+c-----------------------------------------------------------------------
+
+      dtdiss  = idissip * dtvr
+      dtphys  = iphysiq * dtvr
+      unsim   = 1./iim
+      pi      = 2.*ASIN( 1. )
+
+c-----------------------------------------------------------------------
+c
+
+      r       = cpp * kappa
+
+      PRINT*,' R  CP  Kappa ',  r , cpp,  kappa
+c
+c-----------------------------------------------------------------------
+
+       CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)
+c
+c
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inidissip.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inidissip.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inidissip.F	(revision 428)
@@ -0,0 +1,214 @@
+      SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh  ,
+     *                       tetagdiv,tetagrot,tetatemp             )
+c=======================================================================
+c   initialisation de la dissipation horizontale
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      IMPLICIT NONE
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "control.h"
+
+      LOGICAL lstardis
+      INTEGER nitergdiv,nitergrot,niterh
+      REAL    tetagdiv,tetagrot,tetatemp
+      REAL fact,zvert(llm),zz
+      REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm)
+      REAL ullm,vllm,umin,vmin,zhmin,zhmax
+      REAL zllm,z1llm
+
+      INTEGER l,ij,idum,ii
+      REAL tetamin
+
+      EXTERNAL ran1
+      REAL ran1
+
+
+c-----------------------------------------------------------------------
+c
+c   calcul des valeurs propres des operateurs par methode iterrative:
+c   -----------------------------------------------------------------
+
+      crot     = -1.
+      cdivu    = -1.
+      cdivh    = -1.
+
+c   calcul de la valeur propre de divgrad:
+c   --------------------------------------
+      idum = 0
+      DO l = 1, llm
+       DO ij = 1, ip1jmp1
+        deltap(ij,l) = 1.
+       ENDDO
+      ENDDO
+
+      idum  = -1
+      zh(1) = RAN1(idum)-.5
+      idum  = 0
+      DO ij = 2, ip1jmp1
+        zh(ij) = RAN1(idum) -.5
+      ENDDO
+
+      CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1)
+
+      CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+      IF ( zhmin .GE. zhmax  )     THEN
+         PRINT*,'  Inidissip  zh min max  ',zhmin,zhmax
+         STOP'probleme generateur alleatoire dans inidissip'
+      ENDIF
+
+      zllm = ABS( zhmax )
+      DO l = 1,50
+         IF(lstardis) THEN
+            CALL divgrad2(1,zh,deltap,niterh,zh)
+         ELSE
+            CALL divgrad (1,zh,niterh,zh)
+         ENDIF
+
+        CALL minmax(iip1*jjp1,zh,zhmin,zhmax )
+
+         zllm  = ABS( zhmax )
+         z1llm = 1./zllm
+         DO ij = 1,ip1jmp1
+            zh(ij) = zh(ij)* z1llm
+         ENDDO
+      ENDDO
+
+      IF(lstardis) THEN
+         cdivh = 1./ zllm
+      ELSE
+         cdivh = zllm ** ( -1./niterh )
+      ENDIF
+
+c   calcul des valeurs propres de gradiv (ii =1) et  nxgrarot(ii=2)
+c   -----------------------------------------------------------------
+      print*,'calcul des valeurs propres'
+
+      DO  20  ii = 1, 2
+c
+         DO ij = 1, ip1jmp1
+           zu(ij)  = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1)
+         DO ij = 1, ip1jm
+            zv(ij) = RAN1(idum) -.5
+         ENDDO
+         CALL filtreg (zv,jjm,1,2,1,.FALSE.,1)
+
+         CALL minmax(iip1*jjp1,zu,umin,ullm )
+         CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+         ullm = ABS ( ullm )
+         vllm = ABS ( vllm )
+
+         DO  5  l = 1, 50
+            IF(ii.EQ.1) THEN
+ccccc             CALL covcont( 1,zu,zv,zu,zv )
+               IF(lstardis) THEN
+                  CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv )
+               ELSE
+                  CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv )
+               ENDIF
+            ELSE
+               IF(lstardis) THEN
+                  CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv )
+               ELSE
+                  CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv )
+               ENDIF
+            ENDIF
+
+            CALL minmax(iip1*jjp1,zu,umin,ullm )
+            CALL minmax(iip1*jjm, zv,vmin,vllm )
+
+            ullm = ABS  ( ullm )
+            vllm = ABS  ( vllm )
+
+            zllm  = MAX( ullm,vllm )
+            z1llm = 1./ zllm
+            DO ij = 1, ip1jmp1
+              zu(ij) = zu(ij)* z1llm
+            ENDDO
+            DO ij = 1, ip1jm
+               zv(ij) = zv(ij)* z1llm
+            ENDDO
+ 5       CONTINUE
+
+         IF ( ii.EQ.1 ) THEN
+            IF(lstardis) THEN
+               cdivu  = 1./zllm
+            ELSE
+               cdivu  = zllm **( -1./nitergdiv )
+            ENDIF
+         ELSE
+            IF(lstardis) THEN
+               crot   = 1./ zllm
+            ELSE
+               crot   = zllm **( -1./nitergrot )
+            ENDIF
+         ENDIF
+
+ 20   CONTINUE
+
+c   petit test pour les operateurs non star:
+c   ----------------------------------------
+
+c     IF(.NOT.lstardis) THEN
+         fact    = rad*24./float(jjm)
+         fact    = fact*fact
+         PRINT*,'coef u ', fact/cdivu, 1./cdivu
+         PRINT*,'coef r ', fact/crot , 1./crot
+         PRINT*,'coef h ', fact/cdivh, 1./cdivh
+c     ENDIF
+
+c-----------------------------------------------------------------------
+c   variation verticale du coefficient de dissipation:
+c   --------------------------------------------------
+
+      DO l=1,llm
+         zvert(l)=1.
+      ENDDO
+
+      fact=2.
+c
+      DO l = 1, llm
+         zz      = 1. - preff/presnivs(l)
+         zvert(l)= fact -( fact-1.)/( 1.+zz*zz )
+      ENDDO
+
+
+      PRINT*,'Constantes de temps de la diffusion horizontale'
+
+      tetamin =  1.e+6
+
+      DO l=1,llm
+        tetaudiv(l)   = zvert(l)/tetagdiv
+        tetaurot(l)   = zvert(l)/tetagrot
+        tetah(l)      = zvert(l)/tetatemp
+
+        IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l)
+        IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l)
+        IF( tetamin.GT. (1./   tetah(l)) ) tetamin = 1./    tetah(l)
+      ENDDO
+
+      PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod
+      idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+      PRINT *,' INIDI tetamin idissip ',tetamin,idissip
+      idissip = MAX(iperiod,idissip)
+      dtdiss  = idissip * dtvr
+      PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss
+
+      DO l = 1,llm
+         PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l),
+     *                   dtdiss*tetah(l)
+      ENDDO
+
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigeom.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigeom.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigeom.F	(revision 428)
@@ -0,0 +1,698 @@
+c
+c $Header$
+c
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c
+c   ............      Version  du 01/04/2001     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.h"
+#include "comdissnew.h"
+
+c-----------------------------------------------------------------------
+c   ....  Variables  locales   ....
+c
+      INTEGER  i,j,itmax,itmay,iter
+      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
+      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+      REAL coslatm,coslatp,radclatm,radclatp
+      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
+     *     cuij4(iip1,jjp1)
+      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
+     *     cvij4(iip1,jjp1)
+      REAL rlonvv(iip1),rlatuu(jjp1)
+      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
+     *     yprimv(jjm),yprimu(jjp1)
+      REAL gamdi_gdiv, gamdi_grot, gamdi_h
+ 
+      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
+     ,  xprimp025(iip1)
+      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+      SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+c   ------------------------------------------------------------------
+c
+c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+c      aux vitesses covariantes et contravariantes , ou vice-versa ...
+c
+c
+c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+c
+c       on en tire :  u(covariant) = cu * cu * u(contravariant)
+c                     v(covariant) = cv * cv * v(contravariant)
+c
+c
+c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+c                                                          =     =
+c                                           et   - jm/2    <  Y  < jm/2
+c                                                          =     =
+c
+c      ...................................................
+c      ...................................................
+c      .  x  est la longitude du point  en radians       .
+c      .  y  est la  latitude du point  en radians       .
+c      .                                                 .
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c      .        aire(i,j) =  cu(i,j) * cv(j)             .
+c      .                                                 .
+c      . y, dx/dX, dy/dY calcules aux points concernes   .
+c      .                                                 .
+c      ...................................................
+c      ...................................................
+c
+c
+c
+c                                                           ,
+c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+c          pour un adressage plus facile en  ij  .
+c
+c
+c
+c  **************  aux points  u  et  v ,           *****************
+c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
+c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+c
+c  **************  aux points u, v, scalaires, et z  ****************
+c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+c
+c
+c
+c         Exemple de distribution de variables sur la grille dans le
+c             domaine de travail ( X,Y ) .
+c     ................................................................
+c                  DX=DY= 1
+c
+c   
+c        +     represente  un  point scalaire ( p.exp  la pression )
+c        >     represente  la composante zonale du  vent
+c        V     represente  la composante meridienne du vent
+c        o     represente  la  vorticite
+c
+c       ----  , car aux poles , les comp.zonales covariantes sont nulles
+c
+c
+c
+c         i ->
+c
+c         1      2      3      4      5      6      7      8
+c  j
+c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c
+c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+c                 a   IM = 8
+c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
+c                 a   JM = 4
+c
+c      Les points scalaires ( + ) correspondent donc a des valeurs
+c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+c
+c      Les vents    U       ( > ) correspondent a des valeurs  semi-
+c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+c
+c      Les vents    V       ( V ) correspondent a des valeurs entieres
+c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+c
+c
+c
+      WRITE(6,3) 
+ 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
+     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
+     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
+     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+c
+c
+      IF( nitergdiv.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( float(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.2 ) THEN
+        gamdi_h = coefdis/ ( float(niterh) -2. )
+      ELSE
+        gamdi_h = 0.
+      ENDIF
+
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      WRITE(6,990) 
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+c
+c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ELSE
+c
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+c
+ 
+        pxo   = clon *pi /180.
+        pyo   = 2.* clat* pi /180.
+c
+c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+c
+        itmax = 10
+        eps   = .1e-7
+c
+        xo1 = 0.
+        DO 10 iter = 1, itmax
+        x1  = xo1
+        f   = x1+ alphax *SIN(x1-pxo)
+        df  = 1.+ alphax *COS(x1-pxo)
+        x1  = x1 - f/df
+        xdm = ABS( x1- xo1 )
+        IF( xdm.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 iter = 1,itmay
+        y1   = yo1
+        f    = y1 + alphay* SIN(y1-pyo)
+        df   = 1. + alphay* COS(y1-pyo)
+        y1   = y1 -f/df
+        ydm  = ABS(y1-yo1)
+        IF(ydm.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+c
+ 17     CONTINUE
+        transy = yo1
+
+        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,              rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ENDIF
+c
+      ELSE
+c
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   .....................................................................
+
+      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+ 
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 )
+
+  
+      ENDIF
+c
+c  -------------------------------------------------------------------
+
+c
+      rlatu(1)    =     ASIN(1.)
+      rlatu(jjp1) =  - rlatu(1)
+c
+c
+c   ....  calcul  aux  poles  ....
+c
+      yprimu(1)      = 0.
+      yprimu(jjp1)   = 0.
+c
+c
+      un4rad2 = 0.25 * rad * rad
+c
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c   -                                                                  -
+c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+c   -      et de   fext ,  force de coriolis  extensive  .             -
+c   -                                                                  -
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c
+c
+c
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c           ,
+c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+c   point (i,j) .
+c   On definit en outre les coefficients  alpha comme etant egaux a
+c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+c
+c   De meme, toute aire centree en 1 point U est egale a la somme des
+c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+c    Idem pour  airev, airez .
+c
+c       On a ,pour chaque maille :    dX = dY = 1
+c
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+c
+c
+c
+c
+c
+c   ....................................................................
+c
+c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
+c     endroits  que les aireij   .    
+c
+c   ....................................................................
+c
+c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+c
+c
+      DO 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 i = 1, iim
+      xprp           = xprimp025( i )
+      xprm           = xprimm025( i )
+      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+      cuij2  ( i,1 ) = radclatm * xprp
+      cuij3  ( i,1 ) = radclatm * xprm
+      cvij2  ( i,1 ) = 0.5* rad * yprm
+      cvij3  ( i,1 ) = cvij2(i,1)
+  30  CONTINUE
+c
+      DO  i = 1, iim
+      aireij1( i,1 ) = 0.
+      aireij4( i,1 ) = 0.
+      cuij1  ( i,1 ) = 0.
+      cuij4  ( i,1 ) = 0.
+      cvij1  ( i,1 ) = 0.
+      cvij4  ( i,1 ) = 0.
+      ENDDO
+c
+      END IF
+c
+      IF ( j. eq. jjp1 )  THEN
+       yprp               = yprimu2(j-1)
+       rlatp              = rlatu2 (j-1)
+ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
+ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
+c
+      coslatp             = COS( rlatp )
+      radclatp            = 0.5* rad * coslatp
+c
+      DO 31 i = 1,iim
+        xprp              = xprimp025( i )
+        xprm              = xprimm025( i )
+        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+        cuij1(i,jjp1)     = radclatp * xprp
+        cuij4(i,jjp1)     = radclatp * xprm
+        cvij1(i,jjp1)     = 0.5 * rad* yprp
+        cvij4(i,jjp1)     = cvij1(i,jjp1)
+ 31   CONTINUE
+c
+       DO   i    = 1, iim
+        aireij2( i,jjp1 ) = 0.
+        aireij3( i,jjp1 ) = 0.
+        cvij2  ( i,jjp1 ) = 0.
+        cvij3  ( i,jjp1 ) = 0.
+        cuij2  ( i,jjp1 ) = 0.
+        cuij3  ( i,jjp1 ) = 0.
+       ENDDO
+c
+      END IF
+c
+
+      IF ( j .gt. 1 .AND. j .lt. jjp1 )  THEN
+c
+        rlatp    = rlatu2 ( j-1 )
+        yprp     = yprimu2( j-1 )
+        rlatm    = rlatu1 (  j  )
+        yprm     = yprimu1(  j  )
+cc         rlatp    = fy    ( 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 )
+         coslatp  = COS( rlatp )
+         radclatp = 0.5* rad * coslatp
+         radclatm = 0.5* rad * coslatm
+c
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         aireij1 ( i,j ) = ai14 * xprp
+         aireij2 ( i,j ) = ai23 * xprp
+         aireij3 ( i,j ) = ai23 * xprm
+         aireij4 ( i,j ) = ai14 * xprm
+         cuij1   ( i,j ) = radclatp * xprp
+         cuij2   ( i,j ) = radclatm * xprp
+         cuij3   ( i,j ) = radclatm * xprm
+         cuij4   ( i,j ) = radclatp * xprm
+         cvij1   ( i,j ) = 0.5* rad * yprp
+         cvij2   ( i,j ) = 0.5* rad * yprm
+         cvij3   ( i,j ) = cvij2(i,j)
+         cvij4   ( i,j ) = cvij1(i,j)
+  32     CONTINUE
+c
+      END IF
+c
+c    ........       periodicite   ............
+c
+         cvij1   (iip1,j) = cvij1   (1,j)
+         cvij2   (iip1,j) = cvij2   (1,j)
+         cvij3   (iip1,j) = cvij3   (1,j)
+         cvij4   (iip1,j) = cvij4   (1,j)
+         cuij1   (iip1,j) = cuij1   (1,j)
+         cuij2   (iip1,j) = cuij2   (1,j)
+         cuij3   (iip1,j) = cuij3   (1,j)
+         cuij4   (iip1,j) = cuij4   (1,j)
+         aireij1 (iip1,j) = aireij1 (1,j )
+         aireij2 (iip1,j) = aireij2 (1,j )
+         aireij3 (iip1,j) = aireij3 (1,j )
+         aireij4 (iip1,j) = aireij4 (1,j )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 i = 1, iim
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  36  CONTINUE
+c
+c
+      aire    (iip1,j) = aire    (1,j)
+      alpha1  (iip1,j) = alpha1  (1,j)
+      alpha2  (iip1,j) = alpha2  (1,j)
+      alpha3  (iip1,j) = alpha3  (1,j)
+      alpha4  (iip1,j) = alpha4  (1,j)
+      alpha1p2(iip1,j) = alpha1p2(1,j)
+      alpha1p4(iip1,j) = alpha1p4(1,j)
+      alpha2p3(iip1,j) = alpha2p3(1,j)
+      alpha3p4(iip1,j) = alpha3p4(1,j)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                                aireij3(i+1,j)
+      unsaire    ( i,j)= 1./ aire(i,j)
+      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+      airesurg   ( i,j)= aire(i,j)/ g
+  41  CONTINUE
+      aireu     (iip1,j)  = aireu  (1,j)
+      unsaire   (iip1,j)  = unsaire(1,j)
+      unsair_gam1(iip1,j) = unsair_gam1(1,j)
+      unsair_gam2(iip1,j) = unsair_gam2(1,j)
+      airesurg   (iip1,j) = airesurg(1,j)
+  42  CONTINUE
+c
+c
+      DO 48 j = 1,jjm
+c
+        DO i=1,iim
+         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+         DO i=1,iim
+          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
+     *                           aireij4(i+1,j+1)
+          unsairez(i,j) = 1./ airez
+          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+         ENDDO
+        airev     (iip1,j)  = airev(1,j)
+        unsairez  (iip1,j)  = unsairez(1,j)
+        fext      (iip1,j)  = fext(1,j)
+        unsairz_gam(iip1,j) = unsairz_gam(1,j)
+c
+  48  CONTINUE
+c
+c
+c    .....      Calcul  des elongations cu,cv, cvu     .........
+c
+      DO    j   = 1, jjm
+       DO   i  = 1, iim
+       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+       ENDDO
+       DO   i  = 1, iim
+       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+       ENDDO
+       cv       (iip1,j)  = cv       (1,j)
+       cvu      (iip1,j)  = cvu      (1,j)
+       unscv2   (iip1,j)  = unscv2   (1,j)
+       cuv      (iip1,j)  = cuv      (1,j)
+       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+      ENDDO
+
+      DO  j     = 2, jjm
+        DO   i  = 1, iim
+        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
+        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
+        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+        ENDDO
+        cu       (iip1,j)  = cu(1,j)
+        unscu2   (iip1,j)  = unscu2(1,j)
+        cvusurcu (iip1,j)  = cvusurcu(1,j)
+        cusurcvu (iip1,j)  = cusurcvu(1,j)
+        cvuscugam1(iip1,j) = cvuscugam1(1,j)
+        cvuscugam2(iip1,j) = cvuscugam2(1,j)
+        cuscvugam (iip1,j) = cuscvugam(1,j)
+      ENDDO
+
+c
+c   ....  calcul aux  poles  ....
+c
+      DO    i      =  1, iip1
+        cu    ( i, 1 )  =   0.
+        unscu2( i, 1 )  =   0.
+        cvu   ( i, 1 )  =   0.
+c
+        cu    (i, jjp1) =   0.
+        unscu2(i, jjp1) =   0.
+        cvu   (i, jjp1) =   0.
+      ENDDO
+c
+c    ..............................................................
+c
+      DO j = 1, jjm
+        DO i= 1, iim
+         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+        ENDDO
+         airvscu2  (iip1,j)  = airvscu2(1,j)
+         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+      ENDDO
+
+      DO j=2,jjm
+        DO i=1,iim
+         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
+        ENDDO
+         airuscv2  (iip1,j)  = airuscv2  (1,j)
+         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+      ENDDO
+
+c
+c   calcul des aires aux  poles :
+c   -----------------------------
+c
+      apoln       = SSUM(iim,aire(1,1),1)
+      apols       = SSUM(iim,aire(1,jjp1),1)
+      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+c
+c-----------------------------------------------------------------------
+c     gtitre='Coriolis version ancienne'
+c     gfichier='fext1'
+c     CALL writestd(fext,iip1*jjm)
+c
+c   changement F. Hourdin calcul conservatif pour fext
+c   constang contient le produit a * cos ( latitude ) * omega
+c
+      DO i=1,iim
+         constang(i,1) = 0.
+      ENDDO
+      DO j=1,jjm-1
+        DO i=1,iim
+         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+        ENDDO
+      ENDDO
+      DO i=1,iim
+         constang(i,jjp1) = 0.
+      ENDDO
+c
+c   periodicite en longitude
+c
+      DO j=1,jjm
+        fext(iip1,j)     = fext(1,j)
+      ENDDO
+      DO j=1,jjp1
+        constang(iip1,j) = constang(1,j)
+      ENDDO
+
+c fin du changement
+
+c
+c-----------------------------------------------------------------------
+c
+       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+       WRITE(6,995)
+c
+       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       WRITE(6,400) rlonvv
+c
+       WRITE(6,995)
+       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       WRITE(6,995)
+       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+       WRITE(6,995)
+       WRITE(6,400) rlonvv
+       WRITE(6,995)
+
+       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjp1)
+       WRITE(6,995)
+c
+444    format(f10.3,f6.0)
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+995    FORMAT(/)
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigrads.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigrads.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inigrads.F	(revision 428)
@@ -0,0 +1,77 @@
+      subroutine inigrads(if,im
+     s  ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz
+     s  ,dt,file,titlel)
+
+
+      implicit none
+
+      integer if,im,jm,lm,i,j,l,lnblnk
+      real x(im),y(jm),z(lm),fx,fy,fz,dt
+      real xmin,xmax,ymin,ymax
+
+      character file*10,titlel*40
+
+#include "gradsdef.h"
+
+      data unit/66,32,34,36,38,40,42,44,46,48/
+      data nf/0/
+
+      if (if.le.nf) stop'verifier les appels a inigrads'
+
+      print*,'Entree dans inigrads'
+
+      nf=if
+      title(if)=titlel
+      ivar(if)=0
+
+      fichier(if)=file(1:lnblnk(file))
+
+      firsttime(if)=.true.
+      dtime(if)=dt
+
+      iid(if)=1
+      ifd(if)=im
+      imd(if)=im
+      do i=1,im
+         xd(i,if)=x(i)*fx
+         if(xd(i,if).lt.xmin) iid(if)=i+1
+         if(xd(i,if).le.xmax) ifd(if)=i
+      enddo
+      print*,'On stoke du point ',iid(if),'  a ',ifd(if),' en x'
+
+      jid(if)=1
+      jfd(if)=jm
+      jmd(if)=jm
+      do j=1,jm
+         yd(j,if)=y(j)*fy
+         if(yd(j,if).gt.ymax) jid(if)=j+1
+         if(yd(j,if).ge.ymin) jfd(if)=j
+      enddo
+      print*,'On stoke du point ',jid(if),'  a ',jfd(if),' en y'
+
+      print*,'Open de dat'
+      print*,'file=',file
+      print*,'fichier(if)=',fichier(if)
+
+      print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if))
+      print*,file(1:lnblnk(file))//'.dat'
+
+      OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat',
+     s   FORM='UNFORMATTED',
+     s   ACCESS='DIRECT'
+     s  ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1))
+
+      print*,'Open de dat ok'
+
+      lmd(if)=lm
+      do l=1,lm
+         zd(l,if)=z(l)*fz
+      enddo
+
+      irec(if)=0
+
+      print*,if,imd(if),jmd(if),lmd(if)
+      print*,'if,imd(if),jmd(if),lmd(if)'
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniinterp_horizFF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniinterp_horizFF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/iniinterp_horizFF	(revision 428)
@@ -0,0 +1,176 @@
+      subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &       ktotal,iik,jjk,jk,ik,intersec,airen)
+   
+      implicit none
+
+
+
+c ---------------------------------------------------------
+c Prepare l' interpolation des variables d'une grille LMDZ
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c   (Pour chaque case autour d'un point scalaire de la nouvelle
+c    grille, on calcule la surface (en m2)en intersection avec chaque
+c    case de l'ancienne grille , pour la future interpolation)
+c
+c on calcule aussi l' aire dans la nouvelle grille 
+c
+c
+c   Auteur:  F.Forget 01/1995
+c   -------
+c
+c ---------------------------------------------------------
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+c INPUT
+       integer imo, jmo ! dimensions ancienne grille
+       integer imn,jmn  ! dimensions nouvelle grille
+       integer kllm ! taille du tableau des intersections
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+c OUTPUT
+       integer ktotal ! nombre totale d'intersections reperees
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)  ! surface des intersections (m2)
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+
+
+       
+ 
+c Autres variables
+c """"""""""""""""
+       integer i,j,ii,jj,k
+       real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1)
+       real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1)
+       real aa, bb,cc,dd
+       real pi
+
+       pi      = 2.*ASIN( 1. )
+
+
+
+c On repere les frontieres des cases :
+c =================================== 
+c
+c Attention, on ruse avec des latitudes = 90 deg au pole.
+
+
+c  ANcienne grile
+c  """"""""""""""
+      a(1) =   - rlonuo(imo+1)
+      b(1) = rlonuo(1)
+      do i=2,imo+1
+         a(i) = rlonuo(i-1)
+         b(i) =  rlonuo(i)
+      end do
+
+      d(1) = pi/2 
+      do j=1,jmo
+         c(j) = rlatvo(j) 
+         d(j+1) = rlatvo(j)
+      end do
+      c(jmo+1) = -pi/2 
+      
+
+c  Nouvelle grille
+c  """""""""""""""
+      an(1) =  - rlonun(imn+1)
+      bn(1) = rlonun(1)
+      do i=2,imn+1
+         an(i) = rlonun(i-1)
+         bn(i) =  rlonun(i)
+      end do
+
+      dn(1) = pi/2 
+      do j=1,jmn
+         cn(j) = rlatvn(j)
+         dn(j+1) = rlatvn(j)
+      end do
+      cn(jmn+1) = -pi/2 
+
+c Calcul de la surface des cases scalaires de la nouvelle grille
+c ==============================================================
+      do ii=1,imn + 1
+        do jj = 1,jmn+1
+               airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj)))
+        end do
+      end do
+
+c Calcul de la surface des intersections
+c ======================================
+
+c     boucle sur la nouvelle grille
+c     """"""""""""""""""""""""""""
+      ktotal = 0
+      do jj = 1,jmn+1
+       do j=1, jmo+1
+          if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then
+              do ii=1,imn + 1
+                do i=1, imo +1
+                    if (  ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i)))
+     &        .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi)
+     &             .and.(b(i)-2*pi.lt.-pi) )
+     &        .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi)
+     &             .and.(a(i)+2*pi.gt.pi) )
+     &                     )then
+                      ktotal = ktotal +1
+                      iik(ktotal) =ii
+                      jjk(ktotal) =jj
+                      ik(ktotal) =i
+                      jk(ktotal) =j
+
+                      dd = min(d(j), dn(jj))
+                      cc = cn(jj)
+                      if (cc.lt. c(j))cc=c(j)
+                      if((an(ii).lt.b(i)-2*pi).and.
+     &                  (bn(ii).gt.a(i)-2*pi)) then 
+                          bb = min(b(i)-2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi
+                      else if((an(ii).lt.b(i)+2*pi).and.
+     &                       (bn(ii).gt.a(i)+2*pi)) then
+                          bb = min(b(i)+2*pi,bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi
+                      else 
+                          bb = min(b(i),bn(ii))
+                          aa = an(ii)
+                          if (aa.lt.a(i)) aa=a(i)
+                      end if
+                      intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc))
+                     end if
+                end do
+               end do
+             end if
+         end do
+       end do       
+
+
+
+c     TEST  INFO
+c     DO k=1,ktotal 
+c      ii = iik(k) 
+c      jj = jjk(k)
+c      i = ik(k)
+c      j = jk(k)
+c      if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
+c      if (jj.eq.2.and.(ii.eq.1))then
+c          write(*,*) '**************** jj=',jj,'ii=',ii
+c          write(*,*) 'i,j =',i,j
+c          write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
+c          write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
+c          write(*,*) 'intersec(k)',intersec(k)
+c          write(*,*) 'airen(ii,jj)=',airen(ii,jj)
+c      end if
+c     END DO 
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inirappelF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inirappelF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inirappelF	(revision 428)
@@ -0,0 +1,61 @@
+      SUBROUTINE inirappel(teq)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 15/01/93
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      REAL teq(iip1,jjp1,llm)
+
+c   Local:
+c   ------
+
+      REAL dsin,teqj,teql
+      INTEGER i,j,l
+
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         teql=1./8.*(-log(s(l))/kappa-.5)
+         DO j=1,jjp1
+            dsin=sin(rlatu(j))-sin(pi/20.)
+            teqj=cpp/1000.**kappa*
+     s		300.*(1+1./18.*(1.-3.*dsin*dsin)+teql)
+			PRINT*,j,l,teqj
+            DO i=1,iip1
+               teq(i,j,l)=teqj
+            ENDDO
+         ENDDO
+      ENDDO
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/initial0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/initial0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/initial0.F	(revision 428)
@@ -0,0 +1,9 @@
+      SUBROUTINE initial0(n,x)
+      IMPLICIT NONE
+      INTEGER n,i
+      REAL x(n)
+      DO 10 i=1,n
+         x(i)=0.
+10    CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/integrd.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/integrd.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/integrd.F	(revision 428)
@@ -0,0 +1,231 @@
+      SUBROUTINE integrd
+     $  (  iadv, nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
+
+      IMPLICIT NONE
+
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   objet:
+c   ------
+c
+c   Incrementation des tendances dynamiques
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "logic.h"
+#include "temps.h"
+#include "serre.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER iadv(nqmx),nq
+
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
+      REAL q(ip1jmp1,llm,nq)
+      REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
+
+      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
+      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
+
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
+      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
+      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
+      REAL p(ip1jmp1,llmp1)
+      REAL tpn,tps,tppn(iim),tpps(iim)
+      REAL qpn,qps,qppn(iim),qpps(iim)
+      REAL deltap( ip1jmp1,llm )
+
+      INTEGER  l,ij,iq
+
+      EXTERNAL  filtreg,massdair,pression
+      EXTERNAL  SCOPY 
+      REAL SSUM
+      EXTERNAL SSUM
+
+c-----------------------------------------------------------------------
+
+      DO  l = 1,llm
+        DO  ij = 1,iip1
+         ucov(    ij    , l) = 0.
+         ucov( ij +ip1jm, l) = 0.
+         uscr(     ij      ) = 0.
+         uscr( ij +ip1jm   ) = 0.
+        ENDDO
+      ENDDO
+
+
+c    ............    integration  de       ps         ..............
+
+      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
+
+      DO 2 ij = 1,ip1jmp1
+       pscr (ij)    = ps(ij)
+       ps (ij)      = psm1(ij) + dt * dp(ij)
+   2  CONTINUE
+c
+      DO ij = 1,ip1jmp1
+        IF( ps(ij).LT.0. ) THEN
+         PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij)
+         STOP' dans integrd'
+        ENDIF
+      ENDDO
+c
+      DO  ij    = 1, iim
+       tppn(ij) = aire(   ij   ) * ps(  ij    )
+       tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+      ENDDO
+       tpn      = SSUM(iim,tppn,1)/apoln
+       tps      = SSUM(iim,tpps,1)/apols
+      DO ij   = 1, iip1
+       ps(   ij   )  = tpn
+       ps(ij+ip1jm)  = tps
+      ENDDO
+c
+c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
+c
+      CALL pression ( ip1jmp1, ap, bp, ps, p )
+      CALL massdair (     p  , masse         )
+
+      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
+      CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1  )
+c
+
+c    ............   integration  de  ucov, vcov,  h     ..............
+
+      DO 10 l = 1,llm
+
+      DO 4 ij = iip2,ip1jm
+      uscr( ij )   =  ucov( ij,l )
+      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
+   4  CONTINUE
+
+      DO 5 ij = 1,ip1jm
+      vscr( ij )   =  vcov( ij,l )
+      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
+   5  CONTINUE
+
+      DO 6 ij = 1,ip1jmp1
+      hscr( ij )    =  teta(ij,l)
+      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l) 
+     $                + dt * dteta(ij,l) / masse(ij,l)
+   6  CONTINUE
+
+c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
+c
+c
+      DO  ij   = 1, iim
+        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+      ENDDO
+        tpn      = SSUM(iim,tppn,1)/apoln
+        tps      = SSUM(iim,tpps,1)/apols
+
+      DO ij   = 1, iip1
+        teta(   ij   ,l)  = tpn
+        teta(ij+ip1jm,l)  = tps
+      ENDDO
+c
+
+      IF(leapf)  THEN
+         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+      END IF
+
+  10  CONTINUE
+
+
+c
+c   .......  integration de   q   ......
+c
+      IF( iadv(1).NE.3.AND.iadv(2).NE.3 )    THEN
+c
+       IF( forward. OR . leapf )  THEN
+        DO iq = 1,2
+        DO  l = 1,llm
+        DO ij = 1,ip1jmp1
+        q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/
+     $                            finvmasse(ij,l)
+        ENDDO
+        ENDDO
+        ENDDO
+       ELSE
+         DO iq = 1,2
+         DO  l = 1,llm
+         DO ij = 1,ip1jmp1
+         q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l)
+         ENDDO
+         ENDDO
+         ENDDO
+
+       END IF
+c
+      ENDIF
+
+         DO l = 1, llm
+          DO ij = 1, ip1jmp1
+           deltap(ij,l) =  p(ij,l) - p(ij,l+1) 
+          ENDDO
+         ENDDO
+
+         CALL qminimum( q, nq, deltap )
+c
+c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
+c
+
+      DO iq = 1, nq
+        DO l = 1, llm
+
+           DO ij = 1, iim
+             qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
+             qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
+           ENDDO
+             qpn  =  SSUM(iim,qppn,1)/apoln
+             qps  =  SSUM(iim,qpps,1)/apols
+
+           DO ij = 1, iip1
+             q(   ij   ,l,iq)  = qpn
+             q(ij+ip1jm,l,iq)  = qps
+           ENDDO
+
+        ENDDO
+      ENDDO
+
+
+         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+15    continue
+
+c    .................................................................
+
+
+      IF( leapf )  THEN
+         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+      END IF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barx.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barx.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barx.F	(revision 428)
@@ -0,0 +1,215 @@
+       SUBROUTINE inter_barx ( idatmax,xidat,fdat,imodmax,ximod,fmod ) 
+
+c      .... Auteurs :  Robert Sadourny ,  P. Le Van  .....
+c
+       IMPLICIT NONE
+c    ----------------------------------------------------------
+c        INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES
+c            VERSION UNIDIMENSIONNELLE  ,   EN  LONGITUDE .
+c    ----------------------------------------------------------
+c
+c     idat : indice du champ de donnees, de 1 a idatmax
+c     imod : indice du champ du modele,  de 1 a  imodmax
+c     fdat(idat) : champ de donnees (entrees)
+c     fmod(imod) : champ du modele (sorties)
+c     xidat(idat): abscisses des interfaces des mailles donnees
+c     ximod(imod): abscisses des interfaces des mailles modele
+c      ( L'indice 1 correspond a l'interface mailLE 1 / maille 2)
+c      ( Les abscisses sont exprimes en degres)
+
+
+      INTEGER idatmax, imodmax
+      REAL xidat(idatmax),fdat(idatmax),ximod(imodmax),fmod(imodmax)
+
+c    ...  Variables locales ... 
+    
+      REAL xxid(idatmax+1), xxd(idatmax+1), fdd(idatmax+1)
+      REAL  fxd(idatmax+1), xchan(idatmax+1), fdchan(idatmax+1) 
+      REAL  xxim(imodmax)
+
+      REAL x0,xim0,dx,dxm
+      REAL chmin,chmax,pi
+
+      INTEGER imod,idat,i,ichang,id0,id1,nid,idatmax1
+      
+      pi = 2. * ASIN(1.)
+
+c  -----------------------------------------------------
+c   REDEFINITION DE L'ORIGINE DES ABSCISSES
+c    A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE  
+c  -----------------------------------------------------
+      DO imod = 1,imodmax
+       xxim(imod) = ximod(imod)
+      ENDDO
+
+      CALL minmax( imodmax,xxim,chmin,chmax)
+       IF( chmax.LT.6.50 )   THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO imod = 1, imodmax
+        xxim(imod) = xxim(imod) * 180./pi
+        ENDDO  
+       ENDIF
+
+      xim0 = xxim(imodmax) - 360.
+
+      DO imod = 1, imodmax
+       xxim(imod) = xxim(imod) - xim0
+      ENDDO
+
+      idatmax1 = idatmax +1
+
+      DO idat = 1, idatmax
+       xxd(idat) = xidat(idat)
+      ENDDO
+
+      CALL minmax( idatmax,xxd,chmin,chmax)
+       IF( chmax.LT.6.50 )  THEN
+c        PRINT  3
+c        PRINT *,'   conversion des longit. ximod (donnees en radians)'
+c     , ,' en degres  .' 
+c        PRINT  3
+        DO idat = 1, idatmax
+        xxd(idat) = xxd(idat) * 180./pi
+        ENDDO  
+       ENDIF
+
+      DO idat = 1, idatmax
+       xxd(idat) = AMOD( xxd(idat) - xim0, 360. )
+       fdd(idat) = fdat (idat)
+      ENDDO
+c       PRINT *,' xxd redef. origine abscisses '
+c       PRINT 2,(xxd(i),i=1,idatmax)
+
+      DO i = 2, idatmax
+        IF( ( xxd(i) - xxd(i-1)).LT.0. )  THEN
+         ichang = i
+         GO TO 5
+        ENDIF
+      ENDDO
+      GO TO 6
+c
+c  ***  reorganisation  des longitudes entre 0. et 360. degres ****
+c
+ 5    nid = idatmax - ichang +1
+      DO i = 1, nid
+        xchan (i) = xxd(i+ichang -1 )
+        fdchan(i) = fdd(i+ichang -1 )
+      ENDDO
+       DO i=1,ichang -1
+        xchan (i+ nid) = xxd(i)
+        fdchan(i+nid) = fdd(i) 
+       ENDDO
+      DO i =1,idatmax
+       xxd(i) = xchan(i)
+       fdd(i) = fdchan(i)
+      ENDDO
+
+ 6    continue
+
+
+c  ------------------------------------------------
+c    translation des champs de donnees par rapport
+c    a la nouvelle origine, avec redondance de la
+c       maille a cheval sur les bords
+c -----------------------------------------------
+
+      id0 = 0
+      id1 = 0
+
+      DO idat = 1, idatmax
+       IF ( xxd( idatmax1- idat ).LT.360.)   GO TO 10
+       id1 = id1 + 1
+      ENDDO
+
+ 10   DO idat = 1, idatmax
+       IF (xxd(idat).GT.0.) GO TO 20
+       id0 = id0 + 1
+      END DO
+
+ 20   IF( id1.EQ.0 ) GO TO 30
+      DO idat = 1, id1
+       xxid(idat) = xxd(idatmax - id1 + idat) - 360.
+       fxd (idat) = fdd(idatmax - id1 + idat)     
+      END DO
+      DO idat = 1, idatmax - id1
+       xxid(idat + id1) = xxd(idat)
+       fxd (idat + id1) = fdd(idat)
+      END DO
+
+  30  IF(id0.EQ.0) GO TO 40
+      DO idat = 1, idatmax - id0
+       xxid(idat) = xxd(idat + id0)
+       fxd (idat) = fdd(idat + id0)
+      END DO
+
+      DO idat = 1, id0
+       xxid (idatmax - id0 + idat) =  xxd(idat) + 360.
+       fxd  (idatmax - id0 + idat) =  fdd(idat)   
+      END DO
+      GO TO 50
+ 
+ 40   DO idat = 1, idatmax
+       xxid(idat)  = xxd(idat)
+       fxd (idat)  = fdd(idat)
+      ENDDO
+
+ 50   xxid(idatmax1) = xxid(1) + 360.
+      fxd (idatmax1) = fxd(1)
+
+c  ------------------------------------
+c   initialisation du champ du modele
+
+      DO imod = 1, imodmax
+       fmod(imod) = 0.
+      END DO
+ 
+c      PRINT *,' id0 id1 ',id0,id1
+c      PRINT *,' xxim apres translation  '
+c      PRINT 2,(xxim(i),i=1,imodmax)
+c      PRINT *,' xxid apres translation '
+c      PRINT 2,(xxid(i),i=1,idatmax)
+c ---------------------------------------
+c iteration
+
+      x0   = xim0
+      dxm  = 0.
+      imod = 1
+      idat = 1
+ 
+ 100  IF (xxim(imod).LT.xxid(idat)) THEN
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       IF (imod.LE.imodmax) GO TO 100
+  
+      ELSE IF (xxim(imod).GT.xxid(idat)) THEN
+       dx   = xxid(idat) - x0
+       dxm  = dxm + dx
+       fmod(imod) = fmod(imod) + dx * fxd(idat)
+       x0   = xxid(idat)
+       idat = idat + 1
+       GO TO 100
+ 
+      ELSE
+       dx   = xxim(imod) - x0
+       dxm  = dxm + dx
+       fmod(imod) = (fmod(imod) + dx * fxd(idat)) / dxm
+       x0   = xxim(imod)
+       dxm  = 0.
+       imod = imod + 1
+       idat = idat + 1
+       IF (imod.LE.imodmax) GO TO 100
+      END IF
+     
+
+3      FORMAT(1x,70(1h-))
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barxy.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barxy.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_barxy.F	(revision 428)
@@ -0,0 +1,56 @@
+       SUBROUTINE inter_barxy ( interfd,jnterfd,dlonid,dlatid ,
+     ,        champ,imod,jmod,rlonimod,rlatimod, jsort,champint )
+
+c    Auteur :   P. Le Van
+c
+       INTEGER interfd,jnterfd,imod,jmod
+       REAL champ(interfd,jnterfd +1 ),dlonid(interfd),dlatid(jnterfd),
+     ,      champint(imod,jsort)
+       REAL rlonimod(imod),rlatimod(jmod)
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+       REAL champx(imod),champy(jnterfd +1,imod),chpn(imod),chps(imod)
+       REAL chhpn,chhps
+       REAL fmody(jjp1)
+c
+
+       DO j = 1, jnterfd + 1
+        CALL inter_barx( interfd, dlonid, champ( 1,j ),
+     ,                       imod, rlonimod , champx )
+         DO i = 1,imod
+           champy(j,i) = champx(i)
+         ENDDO
+       ENDDO
+
+       DO i = 1, imod
+        CALL inter_bary( jjm,jnterfd,dlatid,champy(1,i),
+     ,                     jmod ,rlatimod,  fmody     )
+          DO j = 1, jsort
+           champint(i,j) = fmody(j)
+          ENDDO
+       ENDDO
+
+       IF( jsort.EQ.jjp1)  THEN
+
+c   ....  Valeurs uniques  aux  poles ....
+c
+         DO i =  1,imod
+          chpn(i)  = aire( i,  1   ) * champint( i, 1   )
+          chps(i)  = aire( i, jjp1 ) * champint( i,jjp1 )
+         ENDDO
+          chhpn  = SSUM(imod,chpn,1)/apoln
+          chhps  = SSUM(imod,chps,1)/apols
+
+         DO i = 1, imod
+          champint( i,  1  ) = chhpn
+          champint( i, jjp1) = chhps
+         ENDDO
+c
+       ENDIF
+
+       RETURN
+       END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_bary.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_bary.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/inter_bary.F	(revision 428)
@@ -0,0 +1,132 @@
+       SUBROUTINE inter_bary( jjm, jdatmax, yjdatt, fdatt  ,
+     ,                       jmodmax, yjmodd,  fmod      )
+c
+c    ...  Auteurs :  Robert Sadourny  , P. Le Van ...
+c
+       IMPLICIT NONE
+
+c  ----------------------------------------------------------
+c       INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES  .
+c         VERSION UNIDIMENSIONNELLE  ,    EN LATITUDE  .
+c  ----------------------------------------------------------
+c
+c     jdat : indice du champ de donnees, de 1 a jdatmax
+c     jmod : indice du champ du modele,  de 1 a jmodmax
+c     fdatt(jdatmax) : champ de donnees (entrees)
+c     yjdatt(jdatmax): ordonnees des interfaces des mailles donnees
+c     yjmodd(jmodmax): ordonnees des interfaces des mailles modele
+c     fmod(jmodmax)  : champ du modele  (sorties)
+c
+c      ( L'indice 1 correspond a l'interface maille 1 / maille 2)
+c      ( Les ordonnees sont exprimees en degres)
+c
+c     jdatmax = nb. d'interfaces  donnees =  nombre de donnees - 1 
+c     jmodmax = nb. d'interfaces  modele
+
+c     Si jmodmax = jjm , on veut interpoler sur les jjm+1 latitudes 
+c       rlatu   du modele ( lat.  des scalaires et de U ) 
+c
+c     Si jmodmax = jjp1 , on veut interpoler sur les jjm latitudes 
+c       rlatv du modele  ( lat.  de  V ) 
+
+c  ....  Arguments  en entree  .......
+
+       INTEGER jjm , jdatmax, jmodmax
+       REAL    yjdatt( jdatmax ) , fdatt( jdatmax +1 )
+       REAL    yjmodd( jmodmax )     
+
+c  ....  Arguments  en sortie  .......
+c
+       REAL    fmod( jmodmax + 1 )
+c
+c   ...... Variables locales  ......
+
+       INTEGER      jmods
+
+       REAL       yjdat ( jdatmax +1 ), fdat( jdatmax +1) 
+       REAL       fscrat( jdatmax +1 )
+       REAL       yjmod ( jmodmax +1 )
+       LOGICAL    decrois
+       SAVE       decrois
+c
+       REAL y0,dy,dym 
+       INTEGER jdat, jmod,i
+c
+
+        DO i = 1, jdatmax +1
+         fdat (i) = fdatt (i)
+        ENDDO
+
+       CALL ord_coord (  jdatmax , yjdatt(1), yjdat(1), decrois ) 
+
+       IF( decrois )   THEN
+         DO i = 1,jdatmax + 1
+          fscrat(i) = fdat(i)
+         ENDDO
+         DO i = 1, jdatmax + 1
+          fdat(i) = fscrat( jdatmax + 2 -i )
+         ENDDO
+
+       ENDIF
+
+       CALL ord_coordm (jmodmax,yjmodd(1),yjmod(1),jjm,jmods,decrois ) 
+c
+c      Initialisation des variables
+c    --------------------------------
+
+       DO jmod = 1, jmods
+        fmod(jmod) = 0.
+       END DO
+
+       y0    = 0.
+       dym   = 0.
+       jmod  = 1
+       jdat  = 1
+c  --------------------
+c      Iteration
+c  --------------------
+
+100    IF ( yjmod(jmod).LT.yjdat(jdat) ) THEN
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        GO TO 100
+
+       ELSE IF ( yjmod(jmod).GT.yjdat(jdat) ) THEN
+        dy         = yjdat(jdat) - y0
+        dym        = dym + dy
+        fmod(jmod) = fmod(jmod) + dy * fdat(jdat)
+        y0         = yjdat(jdat)
+        jdat       = jdat + 1
+
+       GO TO 100
+
+       ELSE
+        dy         = yjmod(jmod) - y0
+        dym        = dym + dy
+        fmod(jmod) = (fmod(jmod) + dy * fdat(jdat)) / dym
+        y0         = yjmod(jmod)
+        dym        = 0.
+        jmod       = jmod + 1
+        jdat       = jdat + 1
+
+        IF ( jmod.LE.jmods ) GO TO 100
+       END IF
+c   ---------------------------------------------
+c    Le test de fin suppose que l'interface 0
+c    est commune aux deux grilles yjdat et yjmod.
+c   ----------------------------------------------
+       IF( decrois )  THEN
+         DO i = 1,jmods
+          fscrat(i) = fmod(i)
+         ENDDO
+         DO i = 1, jmods
+          fmod(i) = fscrat( jmods + 1 -i )
+         ENDDO
+       ENDIF
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_horizFF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_horizFF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_horizFF	(revision 428)
@@ -0,0 +1,144 @@
+      subroutine interp_horiz (varo,varn,imo,jmo,imn,jmn,lm,
+     &  rlonuo,rlatvo,rlonun,rlatvn)  
+
+c===========================================================
+c  Interpolation Horizontales des variables d'une grille LMDZ
+c (des points SCALAIRES au point SCALAIRES)
+c  dans une autre grille LMDZ en conservant la quantite
+c  totale pour les variables intensives (/m2) : ex : Pression au sol
+c
+c Francois Forget (01/1995)
+c===========================================================
+
+      IMPLICIT NONE 
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+        
+       integer imo, jmo ! dimensions ancienne grille (input)
+       integer imn,jmn  ! dimensions nouvelle grille (input)
+
+       real rlonuo(imo+1)     !  Latitude et
+       real rlatvo(jmo)       !  longitude des
+       real rlonun(imn+1)     !  bord des 
+       real rlatvn(jmn)     !  cases "scalaires" (input)
+
+       integer lm ! dimension verticale (input)
+       real varo (imo+1, jmo+1,lm) ! var dans l'ancienne grille (input)
+       real varn (imn+1,jmn+1,lm) ! var dans la nouvelle grille (output)
+
+c Autres variables
+c """"""""""""""""
+       real airetest(imn+1,jmn+1)
+       integer ii,jj,l
+
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+c    Info sur les ktotal intersection entre les cases new/old grille
+       integer kllm, k, ktotal
+       parameter (kllm = 100*100*10)
+       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
+       real intersec(kllm)
+       real R
+       real totn, tots
+
+       logical firstcall, firsttest, aire_ok
+       save firsttest
+       data firsttest /.true./
+       data aire_ok /.true./
+
+       
+
+
+
+c initialisation
+c --------------
+c Si c'est le premier appel, on prepare l'interpolation
+c en calculant pour chaque case autour d'un point scalaire de la
+c nouvelle grille, la surface  de intersection avec chaque
+c    case de l'ancienne grille.
+
+
+        call iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &          ktotal,iik,jjk,jk,ik,intersec,airen)
+
+      do l=1,lm
+       do jj =1 , jmn+1
+        do ii=1, imn+1
+          varn(ii,jj,l) =0.
+        end do
+       end do
+      end do 
+       
+c Interpolation horizontale
+c -------------------------
+c boucle sur toute les ktotal intersections entre les cases
+c de l'ancienne et la  nouvelle grille
+c
+     
+      do k=1,ktotal
+        do l=1,lm
+         varn(iik(k),jjk(k),l) = varn(iik(k),jjk(k),l) 
+     &        + varo(ik(k), jk(k),l)*intersec(k)/airen(iik(k),jjk(k))
+        end do
+      end do
+
+c Une seule valeur au pole pour les variables ! :
+c -----------------------------------------------
+       do l=1, lm
+         totn =0.
+         tots =0.
+           do ii =1, imn+1
+             totn = totn + varn(ii,1,l)
+             tots = tots + varn (ii,jmn+1,l)
+           end do 
+           do ii =1, imn+1
+             varn(ii,1,l) = totn/float(imn+1)
+             varn(ii,jmn+1,l) = tots/float(imn+1)
+           end do 
+       end do
+           
+
+c---------------------------------------------------------------
+c  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST 
+      if (.not.(firsttest)) goto 99
+      firsttest = .false.
+      write (*,*) 'INTERP. HORIZ. : TEST SUR LES AIRES:'
+      do jj =1 , jmn+1
+        do ii=1, imn+1
+          airetest(ii,jj) =0.
+        end do
+      end do 
+      do k=1,ktotal
+         airetest(iik(k),jjk(k))= airetest(iik(k),jjk(k)) +intersec(k) 
+      end do
+      do jj =1 , jmn+1
+       do ii=1, imn+1
+         r = airen(ii,jj)/airetest(ii,jj)
+         if ((r.gt.1.001).or.(r.lt.0.999)) then
+             write (*,*) '********** PROBLEME D'' AIRES !!!',
+     &                   ' DANS L''INTERPOLATION HORIZONTALE'
+             write(*,*)'ii,jj,airen,airetest',
+     &          ii,jj,airen(ii,jj),airetest(ii,jj)
+             aire_ok = .false.
+         end if
+       end do
+      end do
+      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
+ 99   continue
+
+c FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
+c---------------------------------------------------------------
+
+
+
+
+
+
+
+
+        return
+        end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_vert.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_vert.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/interp_vert.F	(revision 428)
@@ -0,0 +1,58 @@
+c******************************************************
+      SUBROUTINE   interp_vert(varo,varn,lmo,lmn,sigmo,sigmn,Nhoriz)
+c
+c interpolation lineaire pour passer
+c a une nouvelle discretisation verticale pour
+c les variables de GCM
+c Francois Forget (01/1995)
+c**********************************************************
+
+      IMPLICIT NONE
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+
+       integer lmo ! dimensions ancienne couches (input)
+       integer lmn ! dimensions nouvelle couches (input)
+
+       real sigmo(lmo) ! niveau des variables dans les anciennes coord
+       real sigmn(lmn) ! niveau des variables dans les nouvelles coord
+
+       integer Nhoriz ! nombre de point horizontale (input)
+
+       real varo(Nhoriz,lmo) ! var dans l'ancienne grille (input)
+       real varn(Nhoriz,lmn) ! var dans la nouvelle grille (output)
+
+c Autres variables
+c """"""""""""""""
+       integer n, ln ,lo 
+       real coef
+
+c run
+c ====
+      do ln=1,lmn
+        if (sigmn(ln).ge.sigmo(1))then
+           do n=1,Nhoriz
+             varn(n,ln) =  varo(n,1)  
+           end do  
+        else if (sigmn(ln).le.sigmo(lmo)) then
+           do n=1,Nhoriz
+             varn(n,ln) =  varo(n,lmo)
+           end do
+        else
+           do lo =1,lmo-1 
+             if ( (sigmn(ln).le.sigmo(lo)).and.
+     &          (sigmn(ln).gt.sigmo(lo+1)) )then
+               coef = (sigmn(ln)-sigmo(lo))/(sigmo(lo+1)-sigmo(lo))
+               do n=1,Nhoriz
+                 varn(n,ln)=varo(n,lo) +coef*(varo(n,lo+1)-varo(n,lo))
+               end do
+             end if
+           end do           
+        end if
+      end do
+      return
+      end    
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/juldate.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/juldate.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/juldate.F	(revision 428)
@@ -0,0 +1,30 @@
+	subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec)
+c	Sous-routine de changement de date:
+c	gregorien>>>date julienne
+c	En entree:an,mois,jour,heure,min.,sec.
+c	En sortie:tjd
+	implicit real (a-h,o-z)
+	frac=((os/60.+om)/60.+oh)/24.
+	ojou=dfloat(ijou)+frac
+	    year=dfloat(ian)
+	    rmon=dfloat(imoi)
+	if (imoi .le. 2) then
+	    year=year-1.
+	    rmon=rmon+12.
+	endif
+	cf=year+(rmon/100.)+(ojou/10000.)
+	if (cf .ge. 1582.1015) then
+	    a=int(year/100)
+	    b=2-a+int(a/4)
+	else
+	    b=0
+	endif
+	tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou)
+     +   +1720994.5+b
+        tjdsec=(ojou-int(ojou))+(tjd-int(tjd))
+        tjd=int(tjd)+int(tjdsec)
+	tjdsec=tjdsec-int(tjdsec)
+	return
+	end
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien.F	(revision 428)
@@ -0,0 +1,38 @@
+      SUBROUTINE laplacien ( klevel, teta, divgra )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c    ....     calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .........      variables  en arguments   ..............
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+c    ............     variables  locales      ..............
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    .......................................................
+
+      EXTERNAL  SCOPY, grad, divergf, filtreg
+
+c
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+
+      CALL filtreg( divgra,  jjp1, klevel,  2, 1, .TRUE., 1 )
+      CALL   grad ( klevel,divgra,   ghx , ghy              )
+      CALL  divergf ( klevel, ghx , ghy  , divgra           )
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_gam.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_gam.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_gam.F	(revision 428)
@@ -0,0 +1,52 @@
+      SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam ,
+     *                        unsapolnga, unsapolsga, teta, divgra )
+
+c  P. Le Van
+c
+c   ************************************************************
+c
+c      ....   calcul de  (div( grad ))   de   teta  .....
+c   ************************************************************
+c    klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    ............     variables  en arguments    ..........
+c
+      INTEGER klevel
+      REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+      REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1),
+     *     unsapolnga, unsapolsga
+c
+c    ...........    variables  locales    .................
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c    ......................................................
+
+      EXTERNAL  filtreg
+      EXTERNAL  SCOPY, grad, divergst
+c
+c
+c   ...  cvuscugam  = ( cvu/ cu ) ** (- gamdissip )
+c   ...  cuvscvgam  = ( cuv/ cv ) ** (- gamdissip )  calcules dans inigeom  ..
+c   ...  unsairegam =  1. /  aire ** (- gamdissip )
+c
+
+      CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 )
+c
+      CALL   grad ( klevel, divgra, ghx, ghy )
+c
+      CALL  diverg_gam ( klevel, cuvsga, cvusga,  unsaigam  ,
+     *                 unsapolnga, unsapolsga, ghx , ghy , divgra )
+
+c
+
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rot.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rot.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rot.F	(revision 428)
@@ -0,0 +1,37 @@
+      SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy )
+c
+c    P. Le Van
+c
+c   ************************************************************
+c    ...  calcul de  ( rotat x nxgrad )  du rotationnel rotin  .
+c   ************************************************************
+c
+c     klevel et rotin  sont des arguments  d'entree pour le s-prog
+c      rotout           est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c 
+c   ..........    variables  en  arguments     .............
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ..........    variables   locales       ................
+c
+      REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel)
+c   ........................................................
+c
+      EXTERNAL  filtreg, nxgrad, rotatf
+c
+      CALL  filtreg ( rotin ,   jjm, klevel,   2, 1, .FALSE., 1 )
+
+      CALL   nxgrad ( klevel, rotin,   ghx ,  ghy               )
+      CALL   rotatf  ( klevel, ghx  ,   ghy , rotout             )
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rotgam.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rotgam.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/laplacien_rotgam.F	(revision 428)
@@ -0,0 +1,42 @@
+      SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout )
+c
+c     P. Le Van
+c
+c   ************************************************************
+c   ... calcul de  (rotat x nxgrad)_gam  du rotationnel rotin ..
+c   ************************************************************
+c     klevel et teta  sont des arguments  d'entree pour le s-prog
+c      divgra     est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c
+c    .............   variables  en  arguments    ...........
+c
+      INTEGER klevel
+      REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel )
+c
+c   ............     variables   locales     ...............
+c
+      INTEGER l, ij
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+c   ........................................................
+c
+      EXTERNAL   nxgrad_gam, rotat_nfil
+c
+
+      CALL   nxgrad_gam ( klevel, rotin,   ghx ,   ghy  )
+      CALL   rotat_nfil ( klevel, ghx  ,   ghy , rotout )
+c
+      DO l = 1, klevel
+        DO ij = 1, ip1jm
+         rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij)
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/lectfluxnc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/lectfluxnc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/lectfluxnc.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/limit_netcdf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/limit_netcdf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/limit_netcdf.F	(revision 428)
@@ -0,0 +1,1297 @@
+C
+C $Header$
+C
+      SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque, pctsrf)
+c
+      IMPLICIT none
+c
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 27/01/94
+C Objet  : Construction des fichiers de conditions aux limites
+C          pour le nouveau
+C          modele a partir de fichiers de climatologie. Les deux
+C          grilles doivent etre regulieres
+c
+c Modifie par z.x.li (le23mars1994)
+c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
+c                         pour lecture netcdf dans LMDZ.3.3
+c Modifie par P;Le Van  ,  juillet 2001
+c-------------------------------------------------------------
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "comconst.h"
+#include "dimphy.h"
+#include "indicesol.h"
+c
+c-----------------------------------------------------------------------
+      LOGICAL interbar, extrap, oldice
+
+      REAL phy_nat(klon,360), phy_nat0(klon)
+      REAL phy_alb(klon,360)
+      REAL phy_sst(klon,360)
+      REAL phy_bil(klon,360)
+      REAL phy_rug(klon,360)
+      REAL phy_ice(klon)
+c
+      real pctsrf_t(klon,nbsrf,360)
+      real pctsrf(klon,nbsrf)
+      REAL verif
+
+      REAL masque(iip1,jjp1)
+      REAL mask(iim,jjp1)
+CPB
+C newlmt indique l'utilisation de la sous-maille fractionnelle
+C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3)
+      LOGICAL newlmt, fracterre
+      PARAMETER(newlmt=.TRUE.)
+      PARAMETER(fracterre = .TRUE.) 
+
+C Declarations pour le champ de depart
+      INTEGER imdep, jmdep,lmdep
+      INTEGER  tbid
+      PARAMETER ( tbid = 60 )        ! >52 semaines
+      REAL  timecoord(tbid)
+c
+      REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
+      REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
+      REAL , ALLOCATABLE :: dlon(:), dlat(:)
+      REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
+      REAL , ALLOCATABLE :: champ_msk(:), champ(:)
+      REAL , ALLOCATABLE :: work(:,:)
+
+      CHARACTER*25 title
+
+C Declarations pour le champ interpole 2D
+      REAL champint(iim,jjp1)
+      real chmin,chmax
+
+C Declarations pour le champ interpole 3D
+      REAL champtime(iim,jjp1,tbid)
+      REAL timeyear(tbid)
+      REAL champan(iip1,jjp1,366)
+
+C Declarations pour l'inteprolation verticale
+      REAL ax(tbid), ay(tbid)
+      REAL by
+      REAL yder(tbid)
+
+
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+CPB
+      INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC
+
+      INTEGER i, j, k, l, ji
+c declarations pour lecture glace de mer
+      INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret
+      INTEGER :: itaul(1), fid
+      REAL :: lev(1), date, dt
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_lic, dlat_lic
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic
+      REAL :: flic_tmp(iip1, jjp1)
+
+c Diverses variables locales
+      REAL time
+! pour la lecture du fichier masque ocean
+      integer :: nid_o2a
+      logical :: couple = .false.
+      INTEGER :: iml_omask, jml_omask
+      REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask
+      REAL, ALLOCATABLE, DIMENSION(:)  :: dlon_omask, dlat_omask
+      REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp
+      real, dimension(klon) :: ocemask_fi
+
+      INTEGER          longcles
+      PARAMETER      ( longcles = 20 )
+      REAL  clesphy0 ( longcles      )
+#include "serre.h"
+      INTEGER ncid,varid,ndimid(4),dimid
+      character*30 namedim
+      CHARACTER*80 :: varname
+
+cIM28/02/2002 <== PM
+      REAL tmidmonth(12)
+      SAVE tmidmonth
+      DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/
+
+c initialisations:
+      CALL conf_gcm( 99, .TRUE. , clesphy0 )
+
+
+      pi     = 4. * ATAN(1.)
+      rad    = 6 371 229.
+      omeg   = 4.* ASIN(1.)/(24.*3600.)
+      g      = 9.8
+      daysec = 86400.
+      kappa  = 0.2857143
+      cpp    = 1004.70885
+      dtvr    = daysec/FLOAT(day_step)
+      CALL inigeom
+c
+C Traitement du relief au sol
+c
+      write(*,*) 'Traitement du relief au sol pour fabriquer masque'
+      ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( lonmsk_ini(imdep) )
+      ALLOCATE(   dlon_msk(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
+#endif
+
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ALLOCATE( latmsk_ini(jmdep) )
+      ALLOCATE(   dlat_msk(jmdep) )
+      ALLOCATE(  champ_msk(imdep*jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
+#endif
+c
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      title='RELIEF'
+
+      CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
+     . dlon_msk, dlat_msk, champ_msk, interbar  )
+
+      DO i = 1, iim
+      DO j = 1, jjp1
+         mask(i,j) = masque(i,j)
+      ENDDO
+      ENDDO
+      WRITE(*,*) 'MASK:'
+      WRITE(*,'(96i1)')INT(mask)     
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la rugosite
+c
+      PRINT*, 'Traitement de la rugosite'
+      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+c
+      ALLOCATE( champ(imdep*jmdep) )
+
+      DO  200 l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+         print*,dimfirst,dimlast
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF 
+   
+        title = 'Rugosite Amip '
+c
+        CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                      dlon, dlat, champ, interbar          )
+
+       IF ( interbar )   THEN
+         DO j = 1, imdep * jmdep
+           champ(j) = LOG(champ(j))
+         ENDDO
+
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la rugosite $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+        CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ ,
+     ,                  iim,jjm,rlonu,rlatv, jjp1,champint )
+         DO j=1,jjp1
+          DO i=1,iim
+           champint(i,j)=EXP(champint(i,j))
+          ENDDO
+         ENDDO
+
+         DO j = 1, jjp1
+           DO i = 1, iim
+             IF(NINT(mask(i,j)).NE.1)  THEN
+               champint( i,j ) = 0.001
+             ENDIF
+           ENDDO
+         ENDDO
+      ELSE
+         CALL rugosite(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint, mask)
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+200      CONTINUE
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+
+      PRINT 222, timeyear
+222   FORMAT(2x,' Time year ',10f6.1)
+c
+        
+      PRINT*, 'Interpolation temporelle dans l annee'
+
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+c
+C Traitement de la glace oceanique
+c
+      PRINT*, 'Traitement de la glace oceanique'
+c
+
+cccIM#define cond_climato
+
+#ifdef cond_climato
+
+cIM22/02/2002
+cIM   ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
+cIM   ierr = NF_OPEN('amip79to95.nc', NF_NOWRITE, ncid)
+      ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid)
+#else
+      ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid)
+#endif
+
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+cIM22/02/2002
+cIM07/03/2002 AMIP.nc & amip79to95.nc
+cIM   ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
+cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc
+      ierr = NF_INQ_VARID(ncid,'sicbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep*jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+ 
+         title = 'Sea-ice Amip '
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                        dlon, dlat, champ, interbar          )
+c
+      IF( oldice )  THEN
+                 CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ELSEIF ( interbar )  THEN
+       IF( l.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour Sea-ice Amip  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+       ENDIF
+cIM07/03/2002 
+cIM22/02/2002 : Sea-ice Amip entre 0. et 1.
+cIM    PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' 
+cIM   DO j = 1, imdep * jmdep
+cIM28/02/2002 <==PM         champ(j) = champ(j)/100.
+cIM14/03/2002      champ(j) = max(0.0,(min(1.0, (champ(j)/100.) )))
+cIM      champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) )))
+cIM   ENDDO
+cIM22/02/2002
+         CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     ,     champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+         CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
+     .             iim, jjp1, rlonv, rlatu, champint )
+      ENDIF
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <== PM  timeyear(l) = timecoord(l)
+cIM      timeyear(l) = timecoord(l)
+cIM07/03/2002      
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      PRINT 222,  timeyear
+c
+      PRINT*, 'Interpolation temporelle'
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : Sea-ice Amip entre 0. et 1.
+      PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+        champan(i, j, k) = 
+     $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.))))
+      ENDDO
+        champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_ice)
+        IF ( newlmt) THEN
+
+CPB  en attendant de mettre fraction de terre
+c
+          WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1.
+          WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0.
+c 
+          IF (fracterre ) THEN
+c            WRITE(*,*) 'passe dans cas fracterre' 
+            pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter)
+            pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic)
+            pctsrf_t(1:klon,is_sic,k) =   phy_ice(1:klon) 
+     $            - pctsrf_t(1:klon,is_lic,k)
+c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP
+            WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+            END WHERE 
+            WHERE( 1. - zmasq(1:klon) .LT. EPSFRA)
+              pctsrf_t(1:klon,is_sic,k) = 0.
+              pctsrf_t(1:klon,is_oce,k) = 0.
+            END WHERE
+            DO i = 1, klon
+              IF ( 1. - zmasq(i) .GT. EPSFRA) THEN 
+                IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN
+                  pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  pctsrf_t(i,is_oce,k) = 0.
+                ELSE 
+                  pctsrf_t(i,is_oce,k) = 1 - zmasq(i) 
+     $                    - pctsrf_t(i,is_sic,k)
+                  IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN
+                    pctsrf_t(i,is_oce,k) = 0.
+                    pctsrf_t(i,is_sic,k) = 1 - zmasq(i)
+                  ENDIF 
+                ENDIF
+              ENDIF  
+              if (pctsrf_t(i,is_oce,k) .lt. 0.) then
+                WRITE(*,*) 'pb sous maille au point : i,k '
+     $              , i,k,pctsrf_t(:,is_oce,k)
+              ENDIF
+              IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + 
+     $          pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k)  - 1.) 
+     $            .GT. EPSFRA) THEN 
+                  WRITE(*,*) 'physiq : pb sous surface au point ', i, 
+     $                pctsrf_t(i, 1 : nbsrf,k), phy_ice(i)
+              ENDIF 
+            END DO
+          ELSE 
+            DO i = 1, klon
+              pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter)
+              IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN
+                pctsrf_t(i,is_sic,k) = 0.
+                pctsrf_t(i,is_oce,k) = 0.                  
+                IF(phy_ice(i) .GE. 1.e-5) THEN
+                  pctsrf_t(i,is_lic,k) = phy_ice(i)
+                  pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) 
+     .                                   - pctsrf_t(i,is_lic,k)
+                ELSE
+                  pctsrf_t(i,is_lic,k) = 0.
+                ENDIF 
+              ELSE
+                pctsrf_t(i,is_lic,k) = 0. 
+                IF(phy_ice(i) .GE. 1.e-5) THEN 
+                  pctsrf_t(i,is_ter,k) = 0.
+                  pctsrf_t(i,is_sic,k) = phy_ice(i)
+                  pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k)
+                ELSE
+                  pctsrf_t(i,is_sic,k) = 0.
+                  pctsrf_t(i,is_oce,k) = 1.                      
+                ENDIF 
+              ENDIF
+              verif = pctsrf_t(i,is_ter,k) +
+     .                pctsrf_t(i,is_oce,k) + 
+     .                pctsrf_t(i,is_sic,k) +
+     .                pctsrf_t(i,is_lic,k)
+              IF ( verif .LT. 1. - 1.e-5 .OR. 
+     $             verif .GT. 1 + 1.e-5) THEN  
+                WRITE(*,*) 'pb sous maille au point : i,k,verif '
+     $                    , i,k,verif
+              ENDIF 
+            END DO
+          ENDIF 
+        ELSE  
+          DO i = 1, klon
+            phy_nat(i,k) = phy_nat0(i)
+            IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN
+              IF (NINT(phy_nat0(i)).EQ.0) THEN
+                phy_nat(i,k) = 3.0
+              ELSE
+                phy_nat(i,k) = 2.0
+              ENDIF
+            ENDIF
+            IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
+              IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
+            ENDIF
+          END DO
+        ENDIF
+      ENDDO
+c
+
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+
+477    continue
+c
+C Traitement de la sst
+c
+      PRINT*, 'Traitement de la sst'
+#ifdef cond_climato
+cIM22/02/2002
+cIM   ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
+cIM   ierr = NF_OPEN('amip79to95.nc', NF_NOWRITE, ncid)
+      ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid)
+#else
+      ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid)
+#endif
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+cIM22/02/2002
+cIM   ierr = NF_INQ_VARID(ncid,'SST',varid)
+      ierr = NF_INQ_VARID(ncid,'tosbcs',varid)
+cIM22/02/2002
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim,'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+ 
+      ALLOCATE( dlon_ini(imdep) )
+      ALLOCATE(     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable SST ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE( dlat_ini(jmdep) )
+      ALLOCATE(     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+cIM28/02/2002
+cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours
+c               Ici on suppose qu'on a 12 mois (de 30 jours).
+      IF (lmdep.NE.12) THEN
+          print *, 'Unknown AMIP file: not 12 months ?'
+          STOP
+       ENDIF
+cIM28/02/2002
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+       ALLOCATE( champ(imdep*jmdep) )
+       IF( extrap )   THEN
+         ALLOCATE ( work(imdep,jmdep) )
+       ENDIF
+c
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Sst Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar     )
+       IF ( extrap )  THEN
+        CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
+       ENDIF
+c
+
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour la Sst Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+       CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     , champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i,j,l) = champint(i,j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+cIM28/02/2002 <==PM  timeyear(l) = timecoord(l)
+         timeyear(l) = tmidmonth(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i,j,l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1,j,k) = champan(1,j,k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' SST au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+cIM14/03/2002 : SST amipbc greater then 271.38
+      PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 '
+      DO k = 1, 360
+      DO j = 1, jjp1
+      DO i = 1, iim
+         champan(i, j, k) = amax1(champan(i, j, k), 271.38)
+      ENDDO
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+      ENDDO
+cIM14/03/2002
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon, 
+     .                  champan(1,1,k), phy_sst(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+       DEALLOCATE( dlon      )
+       DEALLOCATE( dlon_ini  )
+       DEALLOCATE( dlat      )
+       DEALLOCATE( dlat_ini  )
+       DEALLOCATE( champ     )
+c
+C Traitement de l'albedo
+c
+      PRINT*, 'Traitement de l albedo'
+      ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlon_ini(imdep) )
+      ALLOCATE (     dlon(imdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+
+      ALLOCATE ( dlat_ini(jmdep) )
+      ALLOCATE (     dlat(jmdep) )
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', lmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
+#else
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+#endif
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+c
+      ALLOCATE ( champ(imdep*jmdep) )
+
+      DO l = 1, lmdep
+         dimfirst(1) = 1
+         dimfirst(2) = 1
+         dimfirst(3) = l
+c
+         dimlast(1) = imdep
+         dimlast(2) = jmdep
+         dimlast(3) = 1
+c
+         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
+#else
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+#endif
+         if (ierr.ne.0) then
+           print *, NF_STRERROR(ierr)
+           STOP
+         ENDIF
+
+         title='Albedo Amip'
+c
+         CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
+     .                            dlon, dlat, champ, interbar      )
+c
+c
+      IF ( interbar )  THEN
+        IF( l.EQ.1 )  THEN
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+         WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour l Albedo Amip $$$ '
+         WRITE(6,*) '-------------------------------------------------',
+     ,'------------------------'
+        ENDIF
+
+       CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
+     , champ, iim, jjm, rlonu, rlatv, jjp1, champint )
+      ELSE
+       CALL grille_m(imdep, jmdep, dlon, dlat, champ,
+     .          iim, jjp1, rlonv, rlatu, champint   )
+      ENDIF
+c
+         DO j = 1,jjp1
+         DO i = 1, iim
+            champtime (i, j, l) = champint(i, j)
+         ENDDO
+         ENDDO
+      ENDDO
+c
+      DO l = 1, lmdep
+         timeyear(l) = timecoord(l)
+      ENDDO
+      print 222,  timeyear
+c
+C interpolation temporelle
+      DO j = 1, jjp1
+      DO i = 1, iim
+          DO l = 1, lmdep
+            ax(l) = timeyear(l)
+            ay(l) = champtime (i, j, l)
+          ENDDO
+          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
+          DO k = 1, 360
+            time = FLOAT(k-1)
+            CALL SPLINT(ax,ay,yder,lmdep,time,by)
+            champan(i,j,k) = by
+          ENDDO
+      ENDDO
+      ENDDO
+      DO k = 1, 360
+      DO j = 1, jjp1
+         champan(iip1, j, k) = champan(1, j, k)
+      ENDDO
+        IF ( k.EQ.10 )  THEN
+          DO j = 1, jjp1
+            CALL minmax( iip1,champan(1,j,10),chmin,chmax )
+            PRINT *,' Albedo au temps 10 ', chmin,chmax,j
+          ENDDO
+        ENDIF
+      ENDDO
+c
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_alb(1,k))
+      ENDDO
+c
+      ierr = NF_CLOSE(ncid)
+c
+c
+      DO k = 1, 360
+      DO i = 1, klon
+         phy_bil(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      PRINT*, 'Ecriture du fichier limit'
+c
+      ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
+     .                       "Fichier conditions aux limites")
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+      ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+c
+      dims(1) = ndim
+      dims(2) = ntim
+c
+      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")
+      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)")
+      ENDIF 
+      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")
+      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")
+      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")
+      ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+      ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "Rugosite")
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO k = 1, 360
+c
+      debut(1) = 1
+      debut(2) = k
+      epais(1) = klon
+      epais(2) = 1
+c
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+c
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+c
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+      IF (newlmt ) THEN
+          ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais
+     $        ,pctsrf_t(1,is_oce,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais
+     $        ,pctsrf_t(1,is_sic,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais
+     $        ,pctsrf_t(1,is_ter,k))
+          ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais
+     $        ,pctsrf_t(1,is_lic,k))
+      ELSE 
+          ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais
+     $        ,phy_nat(1,k))
+      ENDIF 
+      ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
+      ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
+#endif
+c
+      ENDDO
+c
+      ierr = NF_CLOSE(nid)
+c
+      STOP
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linear.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linear.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linear.F	(revision 428)
@@ -0,0 +1,45 @@
+      subroutine linear(imdep, jmdep, imar, jmar, 
+     .                  champ, retour,
+     .                  icount, iix, jjx, ix, jx, sx, airnx) 
+c      interpolation bidimensionnelle       
+c         avec conservation forcee du flux  
+c=======================================================================
+c    A. HARZALLAH (16/08/90).
+c    Modifie le 15/12/93 par L. Fairhead (LMD/CNRS)
+c                        pour en faire une subroutine
+c=======================================================================
+C=======================================================================
+C  a partir de donnees sur une grille initiale on passe a une 
+C  nouvelle grille en conservant le flux des donnees a travers
+c  la nouvelle grille par interpolation linaire. 
+C=======================================================================
+c input: imdep, nbre de long de la grille de depart
+c        jmdep,  "   "  lat   "     "   "    "    "
+c        imar,  nbre de long de la grille d'arrivee
+c        jmar,  nbre de lat  de la grille d'arrivee
+c        champ, champ a interpoler
+c        iix, jjx, ix, jx indices pour les connections
+c        sx et airnx  poids et aires
+c output: retour, champ interpole
+c
+      implicit none
+      integer imdep, jmdep, imar, jmar, icount
+      real champ(imdep,jmdep),retour(imar,jmar)
+      real sx(icount)
+      real airnx(icount)
+      integer ix(icount),jx(icount),iix(icount),jjx(icount)
+      integer i, j, k
+         
+      do i=1,imar 
+        do j=1,jmar   
+          retour(i,j)=0.  
+        enddo
+      enddo
+             
+      do k=1,icount
+        retour(iix(k),jjx(k))=retour(iix(k),jjx(k))+
+     &                     champ(ix(k),jx(k))*sx(k)/airnx(k)
+      enddo
+      return
+      end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linearb.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linearb.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/linearb.F	(revision 428)
@@ -0,0 +1,127 @@
+      subroutine linearb(imdep, jmdep, xdata, ydata,
+     .                   imar, jmar, x, y, 
+     .                   iix, jjx, ix, jx, sx, airnx, icount)
+c         avec conservation forcee du flux  
+c=======================================================================
+c    A. HARZALLAH (14/08/90).
+c    Modifie le 15/12/93 par L. Fairhead (LMD/CNRS) 
+c                        pour en faire une subroutine
+c
+c Input: imdep, nbre de long de la grille de depart
+c        jmdep,  "   "  lat   "     "   "    "    "
+c        xdata, longitudes de la grille de depart
+c        ydata, latitudes   "   "    "     "   "
+c        imar,  nbre de long de la grille d'arrivee
+c        jmar,  nbre de lat  de la grille d'arrivee
+c        x, longitudes de la grille d'arrivee
+c        y, latitudes de la grille d'arrivee
+C Output: iix, jjx, ix, jx indices pour les connections
+c         sx et airnx  poids et aires
+C=======================================================================
+C  ce programme prepare les interconnections entre les aires 
+c  de la grille initiale et de la nouvelle grille
+C=======================================================================
+      implicit none
+      integer imdep, jmdep
+      real xdata(imdep),ydata(jmdep) 
+      real a(360),b(360),c(360),d(360),air(360,360)
+c------------nouvelle grille--------------------------------- 
+      integer imar, jmar
+      real x(imar),y(jmar),airnx(1)  
+      real an(360),bn(360),cn(360),dn(360), airn(360,360)
+      integer icount
+      integer i, j, ii, jj
+      integer iix(1), jjx(1), ix(1), jx(1)
+      real sx(1) 
+      real pi, eps, s, aa1, aa2, aa3, aa4
+      pi=acos(-1.)
+c----------------------airs de la grille initiale-----------------------
+      eps=0.	
+      a(1)=xdata(1)-(xdata(imdep)-xdata(imdep-1))/2.
+      do i=2,imdep 
+        a(i)=xdata(i-1)+(xdata(i)-xdata(i-1))/2.
+      enddo
+          
+      do i=1,imdep-1	
+        b(i)=xdata(i)+(xdata(i+1)-xdata(i))/2. 
+      enddo
+      b(imdep)=xdata(imdep)+(xdata(2)-xdata(1))/2. 
+          
+      c(1)=ydata(1)-(ydata(jmdep)-ydata(jmdep-1))/2.
+      do j=2,jmdep 
+        c(j)=ydata(j-1)+(ydata(j)-ydata(j-1))/2.
+      enddo
+
+      do j=1,jmdep-1  
+        d(j)=ydata(j)+(ydata(j+1)-ydata(j))/2.
+      enddo 
+      d(jmdep)=ydata(jmdep)+(ydata(2)-ydata(1))/2. 
+       
+      do i=1,imdep
+        do j=1,jmdep
+          air(i,j)=(b(i)-a(i))*(d(j)-c(j))
+        enddo
+      enddo
+c----------------------airs de la nouvelle grille-----------------------
+      	
+      an(1)=a(1) 
+      do i=2,imar	
+        an(i)=x(i-1)+(x(i)-x(i-1))/2.
+      enddo
+
+      do i=1,imar-1	
+        bn(i)=x(i)+(x(i+1)-x(i))/2. 
+      enddo
+      bn(imar)=b(imdep) 
+
+      cn(1)=c(1)     
+      do j=2,jmar  
+        cn(j)=y(j-1)+(y(j)-y(j-1))/2.  
+      enddo
+      	
+      do j=1,jmar-1
+        dn(j)=y(j)+(y(j+1)-y(j))/2.  
+      enddo
+      dn(jmar)=d(jmdep)
+        
+      do i=1,imar
+        do j=1,jmar
+          airn(i,j)=(bn(i)-an(i))*(dn(j)-cn(j))
+        enddo
+      enddo
+c===============definition des connections des airs=====================
+      icount = 0
+      do ii=1,imar 
+        do jj=1,jmar  
+          do i=1,imdep   
+c           if(an(ii).ge.b(i)) goto 3041
+c           if(bn(ii).le.a(i)) goto 3041
+            if(an(ii).lt.b(i).and.bn(ii).gt.a(i)) then
+              do j=1,jmdep 
+c               if(cn(jj).lt.d(j)) goto 3042
+c               if(dn(jj).gt.c(j)) goto 3042
+                if(cn(jj).ge.d(j).and.dn(jj).le.c(j)) then
+                  if(bn(ii).le.b(i)) aa1=bn(ii)
+                  if(bn(ii).gt.b(i)) aa1=b(i)
+                  if(an(ii).ge.a(i)) aa2=an(ii)
+                  if(an(ii).lt.a(i)) aa2=a(i)
+                  if(dn(jj).gt.d(j)) aa3=dn(jj)
+                  if(dn(jj).le.d(j)) aa3=d(j)
+                  if(cn(jj).lt.c(j)) aa4=cn(jj)
+                  if(cn(jj).ge.c(j)) aa4=c(j)
+                  s=(aa1-aa2)*(aa3-aa4)	
+                  icount = icount + 1
+                  iix(icount) = ii
+                  jjx(icount) = jj
+                  ix(icount) = i
+                  jx(icount) = j
+                  sx(icount) = s
+                  airnx(icount) = airn(ii,jj)
+                endif
+              enddo
+            endif
+          enddo
+        enddo
+      enddo
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/logic.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/logic.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/logic.h	(revision 428)
@@ -0,0 +1,10 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'logic.h'
+
+      COMMON/logic/ purmats,physic,forward,leapf,apphys,
+     *  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+
+      LOGICAL purmats,physic,forward,leapf,apphys,statcl,conser,
+     * apdiss,apdelq,saison,ecripar,fxyhypb,ysinus
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/maketa
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/maketa	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/maketa	(revision 428)
@@ -0,0 +1,5 @@
+#@$-r  Maketa
+#@$-lt 00:4:00 -lT 00:4:00 
+cd $workdir/mod
+makegcm etat0_lmd
+#
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbar.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbar.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbar.F	(revision 428)
@@ -0,0 +1,97 @@
+      SUBROUTINE massbar(  masse, massebx, masseby )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse                 est  un argum. d'entree  pour le s-pg ...
+c  ..  massebx,masseby      sont des argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+      REAL    masse( ip1jmp1,llm ), massebx( ip1jmp1,llm )  ,
+     *      masseby(   ip1jm,llm )
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO  ij = 1, ip1jmp1 - 1
+         massebx(ij,l) =  masse( ij, l) * alpha1p2( ij  )     + 
+     *                   masse(ij+1, l) * alpha3p4(ij+1 )
+        ENDDO
+
+c    .... correction pour massebx( iip1,j) .....
+c    ...    massebx(iip1,j)= massebx(1,j) ...
+c
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jmp1, iip1
+         massebx( ij,l ) = massebx( ij - iim,l )
+        ENDDO
+
+
+         DO  ij = 1,ip1jm
+         masseby( ij,l ) = masse(  ij   , l ) * alpha2p3(   ij    )  +
+     *                     masse(ij+iip1, l ) * alpha1p4( ij+iip1 )
+         ENDDO
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbarxy.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbarxy.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massbarxy.F	(revision 428)
@@ -0,0 +1,44 @@
+      SUBROUTINE massbarxy(  masse, massebxy )
+c
+c **********************************************************************
+c
+c  Calcule les moyennes en x et  y de la masse d'air dans chaque maille.
+c **********************************************************************
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..  masse          est  un  argum. d'entree  pour le s-pg ...
+c  ..  massebxy       est  un  argum. de sortie pour le s-pg ...
+c     
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+       REAL  masse( ip1jmp1,llm ), massebxy( ip1jm,llm )
+c
+
+      DO   100    l = 1 , llm
+c
+      DO 5 ij = 1, ip1jm - 1
+      massebxy( ij,l ) = masse(    ij  ,l ) * alpha2(   ij    )   +
+     +                   masse(   ij+1 ,l ) * alpha3(  ij+1   )   +
+     +                   masse( ij+iip1,l ) * alpha1( ij+iip1 )   +
+     +                   masse( ij+iip2,l ) * alpha4( ij+iip2 )
+   5  CONTINUE
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      massebxy( ij,l ) = massebxy( ij - iim,l )
+   7  CONTINUE
+
+100   CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massdair.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massdair.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/massdair.F	(revision 428)
@@ -0,0 +1,107 @@
+      SUBROUTINE massdair( p, masse )
+c
+c *********************************************************************
+c       ....  Calcule la masse d'air  dans chaque maille   ....
+c *********************************************************************
+c
+c    Auteurs : P. Le Van , Fr. Hourdin  .
+c   ..........
+c
+c  ..    p                      est  un argum. d'entree pour le s-pg ...
+c  ..  masse                    est un  argum.de sortie pour le s-pg ...
+c     
+c  ....  p est defini aux interfaces des llm couches   .....
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c  .....   arguments  ....
+c
+      REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm)
+
+c   ....  Variables locales  .....
+
+      INTEGER l,ij
+      REAL massemoyn, massemoys
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c
+c   Methode pour calculer massebx et masseby .
+c   ----------------------------------------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c                       On  a :
+c
+c    massebx(i,j) = masse(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))   +
+c                   masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    masseby(i,j) = masse(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )  +
+c                   masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c
+c=======================================================================
+
+      DO   100    l = 1 , llm
+c
+        DO    ij     = 1, ip1jmp1
+         masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) )
+        ENDDO
+c
+        DO   ij = 1, ip1jmp1,iip1
+         masse(ij+ iim,l) = masse(ij,l)
+        ENDDO
+c
+c       DO    ij     = 1,  iim
+c        masse(   ij   ,l) = masse(   ij   ,l) * aire(  ij    )
+c        masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) 
+c       ENDDO
+c        massemoyn         = SSUM(iim,masse(   1   ,l),1)/ apoln
+c        massemoys         = SSUM(iim,masse(ip1jm+1,l),1)/ apols
+c       DO    ij     = 1, iip1
+c        masse(   ij   ,l )    = massemoyn
+c        masse(ij+ip1jm,l )    = massemoys
+c       ENDDO
+       
+100   CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/merstrlF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/merstrlF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/merstrlF	(revision 428)
@@ -0,0 +1,53 @@
+      SUBROUTINE mer_strl(flux,psi)
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c    Calcul de  1/p*dp/dt = W/p -  div(V) -  1/ps*dW/dsig:
+c    ------------------------------------------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+
+      EXTERNAL multscal,moy2
+
+      REAL flux(iip1,jjm,llm) ! flux meridien pbarv*quantite
+      REAL psi(jjp1,llm)
+
+      INTEGER j,l
+      REAL factmas
+
+      EXTERNAL ssum
+      REAL ssum
+
+c   on calcule d'abord les psi sur les niveaux sigma en partant
+c   du haut de l'atmosphere
+      DO j=1,jjm
+	 psi(j,llm)=dsig(llm)*SSUM(iim,flux(1,j,llm),1)
+      ENDDO
+      DO l=llm-1,1,-1
+         DO j=1,jjm
+            psi(j,l)=psi(j,l+1)+dsig(l)*SSUM(iim,flux(1,j,l),1)
+         ENDDO
+      ENDDO
+
+c   passage aux niveaux s du modele
+      DO l=1,llm-1
+         CALL moy2(jjm,psi(1,l),psi(1,l+1),1.,1.,psi(1,l))
+      ENDDO
+      CALL multscal(jjm,psi(1,llm),.5,psi(1,llm))
+
+c   passage a la grille scalaire
+      DO l=1,llm
+         DO j=jjm,2,-1
+            psi(j,l)=.5*(psi(j,l)+psi(j-1,l))
+         ENDDO
+         psi(1,l)=0.
+         psi(jjp1,l)=0.
+      ENDDO
+
+      factmas=100./g
+      CALL multscal(jjm*llm,psi,factmas,psi)
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax.F	(revision 428)
@@ -0,0 +1,20 @@
+       SUBROUTINE minmax(imax, xi, zmin, zmax )
+c
+c      P. Le Van
+
+       INTEGER imax
+       REAL    xi(imax)
+       REAL    zmin,zmax
+       INTEGER i
+
+       zmin = xi(1)
+       zmax = xi(1)
+
+       DO i = 2, imax
+         zmin = MIN( zmin,xi(i) )
+         zmax = MAX( zmax,xi(i) )
+       ENDDO
+
+       RETURN
+       END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/minmax2.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/modif_etat0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/modif_etat0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/modif_etat0.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/moy2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/moy2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/moy2.F	(revision 428)
@@ -0,0 +1,26 @@
+      SUBROUTINE moy2(np,px,py,pwx,pwy,pz)
+
+c=======================================================================
+c
+c   calcul de la moyenne ponderee de deux champs
+c   z (i) = [ wx*x(i) + wy*y(i) ] / [ wx + wy ]
+c
+c=======================================================================
+
+      IMPLICIT NONE
+      INTEGER np
+      REAL px(np),py(np),pz(np)
+      REAL pwx,pwy
+
+      REAL zwx,zwy
+      INTEGER i
+
+      zwx=pwx/(pwx+pwy)
+      zwy=pwy/(pwx+pwy)
+
+      DO i=1,np
+	 pz(i)=px(i)*zwx+py(i)*zwy
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multipl.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multipl.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multipl.F	(revision 428)
@@ -0,0 +1,17 @@
+      SUBROUTINE multipl(n,x1,x2,y)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   multiplication de deux vecteurs
+c
+c=======================================================================
+c
+      INTEGER n,i
+      REAL x1(n),x2(n),y(n)
+c
+      DO 10 i=1,n
+	 y(i)=x1(i)*x2(i)
+10    CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multscal.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multscal.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/multscal.F	(revision 428)
@@ -0,0 +1,9 @@
+      SUBROUTINE multscal(n,x,lambda,y)
+      IMPLICIT NONE
+      INTEGER i,n
+      REAL lambda,x(n),y(n)
+      DO 10 i=1,n
+         y(i)=x(i)*lambda
+10    CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nudge.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nudge.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nudge.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/nxgrad.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrad.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrad.F	(revision 428)
@@ -0,0 +1,45 @@
+      SUBROUTINE nxgrad (klevel, rot, x, y )
+c
+c     P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+c
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (  rot( ij,l ) - rot( ij-1,l )  ) * cvsurcuv( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (  rot( ij,l ) - rot( ij -iip1,l )  ) * cusurcvu( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrad_gam.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrad_gam.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrad_gam.F	(revision 428)
@@ -0,0 +1,46 @@
+      SUBROUTINE nxgrad_gam( klevel, rot, x, y )
+c
+c  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER   l,ij
+      integer ismin,ismax
+      external ismin,ismax
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij )
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+CDIR$ IVDEP
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij )
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgradst.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgradst.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgradst.F	(revision 428)
@@ -0,0 +1,44 @@
+      SUBROUTINE nxgradst (klevel,rot, x, y )
+c
+      IMPLICIT NONE
+c     Auteur :  P. Le Van
+c
+c   ********************************************************************
+c      calcul du gradient tourne de pi/2 du rotationnel du vect.v
+c   ********************************************************************
+c       rot          est un argument  d'entree pour le s-prog
+c       x  et y    sont des arguments de sortie pour le s-prog
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      INTEGER klevel
+      REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel )
+      INTEGER l,ij
+c
+      DO 10 l = 1,klevel
+c
+      DO 1  ij = 2, ip1jm
+      y(ij,l)=( rot(ij,l) - rot(ij-1,l))
+   1  CONTINUE
+c
+c    ..... correction pour  y ( 1,j,l )  ......
+c
+c    ....    y(1,j,l)= y(iip1,j,l) ....
+
+      DO 2  ij = 1, ip1jm, iip1
+      y( ij,l ) = y( ij +iim,l )
+   2  CONTINUE
+c
+      DO 4  ij = iip2,ip1jm
+      x(ij,l)= rot(ij,l)-rot(ij-iip1,l)
+   4  CONTINUE
+      DO 6 ij = 1,iip1
+      x(    ij    ,l ) = 0.
+      x( ij +ip1jm,l ) = 0.
+   6  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgraro2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgraro2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgraro2.F	(revision 428)
@@ -0,0 +1,67 @@
+       SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry )
+c
+c      P.Le Van .
+c   ***********************************************************
+c                                 lr
+c      calcul de  ( nxgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+c
+c    ......  variables en arguments  .......
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+c    ......   variables locales     ........
+c
+      REAL rot(ip1jm,llm) , signe, nugradrs
+      INTEGER l,ij,iter,lr
+c    ........................................................
+c
+      EXTERNAL    filtreg
+      EXTERNAL  SCOPY, rotatf, nxgrad, laplacien_rotgam
+c
+c
+      signe    = (-1.)**lr
+      nugradrs = signe * crot
+c
+      CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm * klevel, ycov, 1, gry, 1 )
+c
+      CALL     rotatf     ( klevel, grx, gry, rot )
+c
+      CALL laplacien_rot ( klevel, rot, rot,grx,gry      )
+
+c
+c    .....   Iteration de l'operateur laplacien_rotgam  .....
+c
+      DO  iter = 1, lr -2
+        CALL laplacien_rotgam ( klevel, rot, rot )
+      ENDDO
+c
+c
+      CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1)
+      CALL nxgrad ( klevel, rot, grx, gry )
+c
+      DO    l = 1, klevel
+         DO  ij = 1, ip1jm
+          gry( ij,l ) = gry( ij,l ) * nugradrs
+         ENDDO
+         DO  ij = 1, ip1jmp1
+          grx( ij,l ) = grx( ij,l ) * nugradrs
+         ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrarot.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrarot.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/nxgrarot.F	(revision 428)
@@ -0,0 +1,54 @@
+      SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry )
+c   ***********************************************************
+c
+c    Auteur :  P.Le Van  
+c
+c                                 lr
+c      calcul de  ( nXgrad (rot) )   du vect. v  ....
+c
+c       xcov et ycov  etant les compos. covariantes de  v
+c   ***********************************************************
+c     xcov , ycov et lr  sont des arguments  d'entree pour le s-prog
+c      grx   et  gry     sont des arguments de sortie pour le s-prog
+c
+c
+      IMPLICIT NONE
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+#include "logic.h"
+c
+      INTEGER klevel
+      REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel )
+      REAL  grx( ip1jmp1,klevel ),  gry( ip1jm,klevel )
+c
+      REAL rot(ip1jm,llm)
+
+      INTEGER l,ij,iter,lr
+c
+      EXTERNAL    filtreg
+      EXTERNAL       SCOPY, rotat, nXgrad
+c
+c
+      CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 )
+      CALL SCOPY (  ip1jm*klevel, ycov, 1, gry, 1 )
+c
+      DO 10 iter = 1,lr
+      CALL  rotat (klevel,grx, gry, rot )
+      CALL filtreg( rot, jjm, klevel, 2,1, .false.,2)
+      CALL nxgrad (klevel,rot, grx, gry )
+c
+      DO 5  l = 1, klevel
+      DO 2 ij = 1, ip1jm
+      gry( ij,l ) = - gry( ij,l ) * crot
+   2  CONTINUE
+      DO 3 ij = 1, ip1jmp1
+      grx( ij,l ) = - grx( ij,l ) * crot
+   3  CONTINUE
+   5  CONTINUE
+c
+  10  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/offlinenc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/offlinenc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/offlinenc.F	(revision 428)
@@ -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
+         annee_ref=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,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
+         annee_ref=0
+         t_ops =(1./48.)*daysec
+         t_wrt =(1./48.)*daysec
+         dtav=dtvr/float(nsplit)
+         mode=1
+
+c        CALL initdynav(dynhistave_file,day_ini,annee_ref,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/IPSL-CM4_v1x1/libf/dyn3d/ord_coord.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ord_coord.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ord_coord.F	(revision 428)
@@ -0,0 +1,92 @@
+       SUBROUTINE ord_coord ( nmax, xi, xo, decrois )
+
+c   .... Auteur :  P. Le Van  .... 
+c
+c   ... Reordonne eventuellement les coordonnees de la grille donnees ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i,ii
+       REAL pi, degres, chmin, chmax, mult
+c
+
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+     
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) ) mult = -1.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( ABS( xo( 1  ) + mult* 90. ). LT .0.001. OR .
+     ,     ABS( xo(nmax) - mult* 90. ). LT .0.001      )  THEN
+        PRINT *,' Reverifier les valeurs de  xidat  pour les donnees .'
+        PRINT *,' Elles doivent correspondre aux interfaces et non aux',
+     , 'ordonnees des donnees,egales a -90. et 90.deg aux 2 extremites '
+         CALL ABORT
+       ENDIF
+
+       IF( xo(1).GT.xo(nmax) )   THEN
+          DO i = 1, nmax 
+            xscr(i) = xo(i)
+          ENDDO
+          DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+          ENDDO
+            xo (   1    ) =   90.
+       ELSE
+            xo ( nmax +1) =   90.
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         PRINT 2,(xo(ii),ii=1,nmax)
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+c         CALL sort(nmax+1,xo(1))
+        CALL sort(nmax+1,xo)
+       ENDIF
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ord_coordm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ord_coordm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ord_coordm.F	(revision 428)
@@ -0,0 +1,107 @@
+       SUBROUTINE ord_coordm ( nmax, xi, xo, jjm, jmods, decrois )
+
+c   ....  Auteur :  P. Le Van  .... 
+
+c   ... Reordonne eventuellement les coordonnees de la grille modele ...
+c
+       IMPLICIT NONE
+
+c    .....  Arguments  en entree  .....
+
+       INTEGER nmax,jjm
+       REAL xi(nmax)
+
+c    .....  Arguments  en sortie  .....
+c
+       REAL xo(nmax+1) 
+       LOGICAL decrois
+       INTEGER jmods
+
+c    .... Variables  locales  ....
+
+       REAL xscr(nmax)
+       INTEGER i
+       REAL pi, degres, chmin, chmax,mult
+c
+       DO i = 1, nmax 
+        xo(i) = xi(i)
+       ENDDO
+
+       mult = 1.
+       IF( xo(1).GT.xo(nmax) )  mult = - 1.
+       IF( nmax.EQ.jjm    ) jmods = nmax +1
+       IF( nmax.EQ.jjm +1 ) jmods = nmax -1 
+     
+       pi     = 2.*ASIN(1.)
+       degres = 180./pi
+       decrois = .FALSE.
+
+       CALL minmax(nmax,xo(1),chmin,chmax)
+
+       IF(chmax.LT.6.5 )  THEN
+          DO i = 1,nmax
+           xo(i) = xo(i) * degres 
+          ENDDO
+       ENDIF
+
+       IF( nmax.EQ.jjm )   THEN
+         IF( xo(1).GT.xo(nmax) )   THEN
+           DO i = 1, nmax 
+            xscr(i) = xo(i)
+           ENDDO
+           DO i = 1, nmax 
+            xo(i+1) = xscr(i)
+           ENDDO
+            xo (   1    ) =   90.
+         ELSE
+            xo ( nmax+1 ) =   90.
+         ENDIF
+       ELSE
+          IF( nmax.NE.jjm +1 )   THEN
+             PRINT *,'  Dans la routine ord_coordm , l argument nmax '
+             PRINT *,'  n est pas egal a jjm ni a jjm +1 . Corriger !'
+             CALL ABORT
+          ELSE
+            IF( ABS( xo(1)+ mult * 90.).GT.0.01 )  THEN
+              PRINT *,' Avec nmax =',nmax,'on devrait avoir des',
+     ,    ' ordonnees = 90. deg pour j=1 ou jjm+1 ! '
+             CALL ABORT
+            ELSE
+               IF( xo(1).LT.xo(nmax) )  THEN
+                 DO i = 1, nmax
+                  xscr(i) = xo(i)
+                 ENDDO
+                 DO i = 1, nmax -1
+                  xo(i) = xscr(i+1)
+                 ENDDO
+               ENDIF
+            ENDIF
+          ENDIF
+       ENDIF
+
+       IF ( xo(2).LT.xo(1) ) decrois =.TRUE.
+
+       DO i = 3, nmax 
+
+        IF(decrois.AND.xo(i).GT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT 
+        ENDIF
+        IF(.NOT.decrois.AND.xo(i).LT.xo(i-1) ) THEN
+         PRINT 1
+         CALL ABORT
+        ENDIF
+
+       ENDDO
+        
+       IF( decrois )  THEN
+         CALL sort(jmods,xo(1))
+       ENDIF
+
+
+1      FORMAT(5x,' Incoherence dans les valeurs des latitudes de la ',
+     ,  'grille du modele ')
+2      FORMAT(1x,8f8.2)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/para_netcdf.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/para_netcdf.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/para_netcdf.h	(revision 428)
@@ -0,0 +1,10 @@
+c
+      INTEGER lons ,lats,levs
+      PARAMETER (lons = 320, lats = 161, levs = 17)
+c
+c     *******    a  changer  eventuellement   ********`
+c
+c  *** Ces valeurs de lons et de lats correspondent a une grille 1.125 x1.125
+c                  du fichier d'entree en Netcdf     ******
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/paramet.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/paramet.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/paramet.h	(revision 428)
@@ -0,0 +1,19 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3
+     s    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pbar.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pbar.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pbar.F	(revision 428)
@@ -0,0 +1,122 @@
+      SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c *********************************************************************
+c
+c          pext               est  un argum. d'entree  pour le s-pg ..
+c     pbarx,pbary et pbarxy  sont des argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comgeom.h"
+
+      REAL pext( ip1jmp1 ),  pbarx ( ip1jmp1 )
+      REAL pbary(  ip1jm  ),  pbarxy(  ip1jm  )
+
+      INTEGER   ij
+      EXTERNAL SCOPY
+
+
+
+      DO 1 ij = 1, ip1jmp1 - 1
+      pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1)
+   1  CONTINUE
+
+c    .... correction pour pbarx( iip1,j) .....
+
+c    ...    pbarx(iip1,j)= pbarx(1,j) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jmp1, iip1
+      pbarx( ij ) = pbarx( ij - iim )
+   2  CONTINUE
+
+
+      DO 3 ij = 1,ip1jm
+      pbary( ij ) = pext(   ij  )   * alpha2p3(   ij   )     +
+     *              pext( ij+iip1 ) * alpha1p4( ij+iip1 )
+   3  CONTINUE
+
+
+      DO 5 ij = 1, ip1jm - 1
+      pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     pbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      pbarxy( ij ) = pbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pres2lev.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pres2lev.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pres2lev.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/pression.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pression.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/pression.F	(revision 428)
@@ -0,0 +1,29 @@
+      SUBROUTINE pression( ngrid, ap, bp, ps, p )
+c
+
+c      Auteurs : P. Le Van , Fr.Hourdin  .
+
+c  ************************************************************************
+c     Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du
+c     sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) 
+c     couches , avec  p(ij,llm +1) = 0.  et p(ij,1) = ps(ij)  .      
+c  ************************************************************************
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+      INTEGER ngrid
+      INTEGER l,ij
+ 
+      REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) 
+      
+      DO    l    = 1, llmp1
+        DO  ij   = 1, ngrid
+         p(ij,l) = ap(l) + bp(l) * ps(ij)
+        ENDDO
+      ENDDO
+   
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ps_amontF
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ps_amontF	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ps_amontF	(revision 428)
@@ -0,0 +1,454 @@
+      SUBROUTINE ps_amont(nq,iq,q,w,pbaru,pbarv,dq)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      INTEGER nq,iq
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq), dq( ip1jmp1,llm,nq )
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL pente(ip1jmp1),xg(ip1jmp1),xd(ip1jmp1),xs(ip1jmp1) ,
+     *     xn(ip1jmp1),xb(ip1jmp1),xh(ip1jmp1)
+      REAL qg(ip1jmp1),qd(ip1jmp1),qs(ip1jmp1) ,
+     *     qn(ip1jmp1),qb(ip1jmp1,llm),qh(ip1jmp1,llm)
+      REAL qbyv(ip1jm,llm), qbxu(ip1jmp1,llm), ww,dqh(ip1jmp1,llm)
+      REAL qpns,qpsn
+      logical first,extrpn,extrps
+      save first
+c
+c
+      REAL      SSUM,CVMGP,CVMGT
+      EXTERNAL  SSUM, convflu
+
+      data first/.true./
+
+      if(first) then
+         print*,'SCHEMA AMONT NOUVEAU'
+         first=.false.
+      endif
+
+
+c
+c
+      IF( forward.OR.leapf )   THEN
+c
+c
+      DO  100  l = 1, llm
+c
+c   ...  Boucle sur les  llm niveaux verticaux ...
+c
+c
+c  --------------------------------------------------------------
+c  --------------------------------------------------------------
+c  .............      Traitement en longitude     ...............
+c  --------------------------------------------------------------
+c  --------------------------------------------------------------
+c
+c     
+c        |          |            |           |
+c        |   q(i-1) |     q(i)   |   q(i+1)  |
+c        |          |qg(i)  qd(i)|qg(i+1)    |
+c
+c
+c      En  longitude ,
+c      Pour chaque maille ( i ) avec q(i,j,l,iq), on cherche a determiner
+c      avec une methode de ' pente' les valeurs qg(i) et qd(i) qui se trouvent
+c      au bord gauche et droite de cette maille .
+c
+c      Si ( q(i+1)-q(i) ) * ( q(i)-q(i-1)) < 0. ,on a qg(i)=qd(i)=q(i)
+c              Sinon
+c      qg(i)= q(i) - 1/4 * ( q(i+1) - q(i-1))
+c      qd(i)= q(i) + 1/4 * ( q(i+1) - q(i-1) )
+c
+c      On utilisera la meme methode pour determiner les valeurs qs(i) et qn(i)
+c      en latitude , ainsi que les valeurs qb(i) et qh(i) en  altitude .
+c
+c
+c
+       DO      ij    = 1,iip1
+       qg(ij)        = 0.
+       qd(ij)        = 0.
+       qg(ij+ ip1jm) = 0.
+       qd(ij+ ip1jm) = 0.
+       ENDDO
+c
+c     ....  calculs pour les lignes j= 2 a j = jjm  ....
+c
+       DO   ij    = iip2, ip1jm -1
+       pente(ij)  =( q(ij+1,l,iq)-q(ij,l,iq)) *(q(ij,l,iq)-q(ij-1,l,iq)) 
+       xg(ij)     = q(ij,l,iq) - 0.25 * ( q(ij+1,l,iq) - q(ij-1,l,iq) )
+       xd(ij)     = q(ij,l,iq) + 0.25 * ( q(ij+1,l,iq) - q(ij-1,l,iq) )
+       qg(ij)     = CVMGP( xg(ij), q(ij,l,iq) ,pente(ij) )
+       qd(ij)     = CVMGP( xd(ij), q(ij,l,iq), pente(ij) )
+       ENDDO
+
+c    ... Correction aux points  ( i= 1,  j )  .....
+c
+       DO   ij   = iip2, ip1jm, iip1
+       pente(ij) = ( q(ij+1,l,iq) - q(ij,l,iq) )     * 
+     *                                ( q(ij,l,iq)  - q(ij+iim-1,l,iq) )
+       xg(ij)    = q(ij,l,iq) - 0.25* ( q(ij+1,l,iq)- q(ij+iim-1,l,iq) )
+       xd(ij)    = q(ij,l,iq) + 0.25* ( q(ij+1,l,iq)- q(ij+iim-1,l,iq) )
+       qg(ij)    = CVMGP( xg(ij), q(ij,l,iq) ,pente(ij) )
+       qd(ij)    = CVMGP( xd(ij), q(ij,l,iq), pente(ij) )
+       ENDDO
+c
+c    ... Correction aux points ( i= iip1,  j ) .....
+c
+       DO     ij      = iip2, ip1jm, iip1
+       qg( ij+ iim  ) = qg( ij )
+       qd( ij+ iim )  = qd( ij )
+       ENDDO
+c
+c   .............................................................
+c   .........    Limitation des pentes a gauche des boites  .....
+c
+c    Si (q(i)-qg(i))*(qg(i)-q(i-1)) < 0.  , on a  qg(i)=q(i-1)  
+c                                         et qd(i)=2*q(i)-qg(i)
+c   .............................................................
+c
+       DO   ij  = iip2,ip1jm -1
+       pente(ij)= ( qg(ij) -q(ij-1,l,iq))*(q(ij,l,iq)-qg(ij) )
+       qg(ij)   = CVMGP( qg(ij), q(ij-1,l,iq) ,pente(ij) )
+       qd(ij)   = CVMGP( qd(ij), 
+     *                q(ij,l,iq)+ q(ij,l,iq) -qg(ij) , pente(ij) ) 
+       ENDDO
+c
+c      .....   Correction aux points ( i= 1,  j )  ......
+c
+       DO    ij  = iip2 ,ip1jm, iip1
+       qg(ij)    =  qg(ij+ iim)
+       qd(ij)    =  qd(ij+ iim)
+       ENDDO
+c    
+c      ...............................................................
+c      ...... Limitation des pentes a droite des boites      .........
+c      Si (q(i+1)-qd(i))*(qd(i)-q(i)) < 0. , on a qd(i)=q(i+1)
+c                                              et qg(i)=2*q(i)-qd(i) .
+c      ...............................................................
+c
+       DO ij = iip2, ip1jm -1
+       pente(ij) = ( qd(ij)-q(ij,l,iq) )*(q(ij+1,l,iq)-qd(ij) ) 
+       qd(ij)    =  CVMGP( qd(ij), q(ij+1,l,iq), pente(ij) )
+       qg(ij)    =  CVMGP( qg(ij), 
+     *                q(ij,l,iq)+ q(ij,l,iq) -qd(ij) , pente(ij) ) 
+       ENDDO
+c
+c      ....  Correction aux points ( i = iip1, j )  .....
+c
+       DO     ij     = iip2, ip1jm, iip1
+       qg( ij+ iim ) = qg( ij )
+       qd( ij+ iim ) = qd( ij )
+       ENDDO
+c
+
+c     -------------------------------------------------------------
+c     -------------------------------------------------------------
+c     .............    Traitement en  latitude    .................
+c     -------------------------------------------------------------
+c     -------------------------------------------------------------
+c
+c
+c      q(j=1)   PN
+c   --------------
+c     ---------  
+c   --------------
+c
+c      q(j-1)
+c
+c   --------------
+c            qn(j)
+c      q(j)
+c            qs(j)
+c   --------------
+c        
+c      q(j+1)
+c
+c   --------------
+c
+c      q(jjp1)  PS
+c
+c   --------------
+c
+c
+c     ......   operations pour les lignes j= 2 a j= jjm  .......
+c
+       DO    ij    = iip2, ip1jm
+       pente(ij)   = ( q(ij-iip1,l,iq)- q(ij,l,iq)  )  *
+     *               ( q(ij,l,iq) - q(ij+iip1,l,iq) )
+       xs(ij) = q(ij,l,iq) - 0.25 * ( q(ij-iip1,l,iq) -q(ij+iip1,l,iq) )
+       xn(ij) = q(ij,l,iq) + 0.25 * ( q(ij-iip1,l,iq) -q(ij+iip1,l,iq) )
+       qs(ij) = CVMGP( xs(ij), q(ij,l,iq), pente(ij) )
+       qn(ij) = CVMGP( xn(ij), q(ij,l,iq), pente(ij) )
+       ENDDO
+c
+c
+c     ......    Calculs aux  poles   .............................
+c     ............................................................
+c
+c     On n'a pas besoin des valeurs de  qn au pole Nord ( j=    1) ,
+c      ainsi que de celles de           qs au pole Sud  ( j= jjp1)
+c
+c
+      airej2 = SSUM( iim, aire(iip2), 1 )
+      airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l,iq)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l,iq)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+c
+c     qpns , val.moyenne de q sur la ligne j= 2
+c     qpsn , val.moyenne de q sur la ligne j= jjm
+c
+c
+c
+c  on cherche si on a un extremum au pole
+c
+      extrpn=.true.
+      extrps=.true.
+      DO ij=2,iim
+         if((q(iip1+i,l,iq)-q(1,l,iq))*(q(iip2,l,iq)-q(1,l,iq)).lt.0.)
+     .   extrpn=.false.
+         if((q(ip1jm-iip1+i,l,iq)-q(1,l,iq))*
+     .     (q(ip1jm-iim,l,iq)-q(1,l,iq)).lt.0.)
+     .      extrps=.false.
+      ENDDO
+
+c   calcul des pentes au pole
+
+      if(extrpn) then
+         DO    ij     = 1, iip1
+            qs(ij)= q(ij,l,iq)
+         ENDDO
+      else
+         DO    ij     = 1, iip1
+            qs(ij)= q(ij,l,iq) + 0.5 * ( q(ij+ iip1,l,iq) - qpns )
+         ENDDO
+      endif
+
+      if(extrps) then
+         DO    ij     = 1, iip1
+            qn(ij+ip1jm) = q(ij+ip1jm,l,iq)
+         ENDDO
+      else
+         DO    ij     = 1, iip1
+            qn(ij+ip1jm) = q(ij+ip1jm,l,iq) +   0.5 *
+     *                    ( q(ij+ip1jm-iip1,l,iq) - qpsn )
+         ENDDO
+      endif
+
+c
+c
+c    .........................................................
+c    ......    Limitation des pentes au sud des boites   .....
+c    .........................................................    
+c
+      DO   ij     = 1, ip1jm
+      pente(ij)   = ( qs(ij) - q (ij+iip1,l,iq) )   *
+     *              ( q( ij,l,iq) - qs( ij ) )
+      qs(ij) = CVMGP( qs(ij) , q(ij+iip1,l,iq), pente(ij) )
+      qn(ij) = CVMGP( qn(ij) , 
+     *                q(ij,l,iq)+ q(ij,l,iq) -qs(ij), pente(ij) )
+      ENDDO
+c
+c
+c     .......................................................
+c     .... Limitation des pentes au nord des boites .........
+c     .......................................................
+c
+      DO   ij     = iip2, ip1jmp1
+      pente(ij)   = ( qn( ij  ) -  q(ij,l,iq) )  *
+     *              (  q(ij-iip1,l,iq) - qn(ij) )
+      qn(ij)      = CVMGP( qn(ij), q(ij-iip1,l,iq), pente(ij) )
+      qs(ij)      = CVMGP( qs(ij), 
+     *                q(ij,l,iq)+ q(ij,l,iq) -qn(ij) , pente(ij) )
+      ENDDO
+c
+c
+c    .............................................................
+c    .....   Calculs des flux de  q  sur le plan horizontal ......
+c    .............................................................
+c
+c
+c
+c      
+c      ....  Selon   X  .... 
+c
+         DO  ij     = iip2, ip1jm - 1
+c
+         qbxu( ij,l ) =  pbaru( ij,l )   *
+     *            CVMGT( qd(ij), qg(ij +1), pbaru(ij,l).GT.0. )
+         ENDDO
+c
+c     ..... correction  pour  qbxu(iip1,j,l)   .....
+c     ...   qbxu(iip1,j,l)= qbxu(1,j,l)  ...
+c
+c           &&&CDIR$ IVDEP
+         DO    ij     = iip1 +iip1, ip1jm, iip1
+         qbxu( ij,l ) = qbxu( ij - iim, l )
+         ENDDO
+c
+c      .... Selon Y  .....
+c
+         DO    ij     = 1, ip1jm
+         qbyv( ij,l ) =  pbarv( ij,l )    *
+     *             CVMGT( qn(ij+iip1), qs(ij), pbarv(ij,l).GT.0. )
+         ENDDO
+c
+c
+c
+  100  CONTINUE
+c
+c     ..........................................................
+c     ( ... fin des traitements en longitude et latitude  ... )
+c
+c
+c   stockage dans  dqh  de la convergence horiz.du flux d'humidite  .
+c                   ....
+c
+c
+                 CALL  convflu( qbxu, qbyv, llm, dqh )
+c
+c
+c
+c    ----------------------------------------------------------------
+c    ----------------------------------------------------------------
+c    .............      Traitement  en  altitude        .............
+c    ----------------------------------------------------------------
+c    ----------------------------------------------------------------
+c
+c
+c     -------------
+c        q (llm)
+c
+c     -------------
+c     -------------
+c
+c        q(l+1)
+c
+c     -------------
+c             qh(l)
+c        q(l)
+c             qb(l)
+c     -------------
+c
+c        q(l-1)
+c
+c     -------------
+c     -------------
+c        q(1)
+c     -------------
+c
+c
+c    ... Calculs pour les niveaux 2 a llm -1  ...
+c
+c
+      DO  200   l = 2, llm -1
+
+       DO   ij     = 1, ip1jmp1
+       pente(ij)   = ( q(ij, l+1 ,iq)  - q(ij , l  ,   iq) )  * 
+     *               ( q(ij,   l ,iq)  - q(ij ,l-1 ,   iq) )
+       xb(ij)      = q(ij,l,iq) - 0.25* ( q(ij,l+1,iq) - q(ij,l-1,iq) )
+       xh(ij)      = q(ij,l,iq) + 0.25* ( q(ij,l+1,iq) - q(ij,l-1,iq) )
+       qb(ij,l)    = CVMGP( xb(ij), q(ij,l,iq), pente(ij) )
+       qh(ij,l)    = CVMGP( xh(ij), q(ij,l,iq), pente(ij) )
+       ENDDO
+c
+c     ........................................................
+c     ......  Limitation des pentes en bas des boites   ......
+c     ........................................................
+c
+       DO   ij     = 1, ip1jmp1
+       pente(ij)   = ( qb(ij,l) - q ( ij,l-1,iq) )   *
+     *                ( q (ij,l,iq) - qb( ij,l ) )
+       qb(ij,l)    = CVMGP( qb(ij,l), q(ij,l-1,iq), pente(ij) )
+       qh(ij,l)    = CVMGP( qh(ij,l), 
+     *               q(ij,l,iq) + q(ij,l,iq) -qb(ij,l), pente(ij) )
+       ENDDO
+c
+c
+c     ........................................................
+c     ......  Limitation des pentes en haut des boites   ......
+c     ........................................................
+c
+       DO   ij     = 1, ip1jmp1
+       pente(ij)   = ( qh(ij,l) - q ( ij,l+1,iq) )   *
+     *                ( q (ij,l,iq) - qh( ij,l ) )
+       qh(ij,l)    = CVMGP( qh(ij,l), q(ij,l+1,iq), pente(ij) )
+       qb(ij,l)    = CVMGP( qb(ij,l), 
+     *               q(ij,l,iq) + q(ij,l,iq) -qh(ij,l), pente(ij) )
+       ENDDO
+c
+c
+  200  CONTINUE
+c
+c
+c    ............................................................
+c    .....     Calculs pour les niveaux l= 1 et l= llm  .........
+c    ............................................................
+c
+      DO   ij    = 1, ip1jmp1
+      qb(ij,1)   = q(ij, 1 , iq)
+      qb(ij,llm) = q(ij,llm, iq)
+      qh(ij,1)   = q(ij, 1 , iq)
+      qh(ij,llm) = q(ij,llm, iq)
+      ENDDO
+c
+
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dqh pour calculer dq
+c
+
+       DO 300 l = 1,llmm1
+c
+         DO  ij = 1,ip1jmp1
+          ww= - w( ij,l+1 ) * 
+     *        CVMGT ( qh(ij,l), qb(ij,l+1), w(ij,l+1).LT.0.)
+
+          dq (ij, l ,iq ) = dqh(ij, l )   - dsig1( l ) * ww
+          dqh(ij,l+1    ) = dqh(ij,l+1)   + dsig1(l+1) * ww
+         ENDDO
+c
+  300   CONTINUE 
+c
+c
+c
+        DO  ij = 1,ip1jmp1
+          dq( ij,llm,iq ) = dqh( ij,llm )
+        END DO
+c
+c
+      END IF
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/psextbar.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/psextbar.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/psextbar.F	(revision 428)
@@ -0,0 +1,105 @@
+      SUBROUTINE psextbar ( ps, psexbarxy )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c **********************************************************************
+c calcul des moyennes en x et en y de (pression au sol*aire variable) ..
+c **********************************************************************
+c
+c         ps          est un  argum. d'entree  pour le s-pg ..
+c         psexbarxy   est un  argum. de sortie pour le s-pg ..
+c
+c   Methode:
+c   --------
+c
+c    A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires
+c       alpha1(i,j)  calcule  au point ( i+1/4,j-1/4 )
+c       alpha2(i,j)  calcule  au point ( i+1/4,j+1/4 )
+c       alpha3(i,j)  calcule  au point ( i-1/4,j+1/4 )
+c       alpha4(i,j)  calcule  au point ( i-1/4,j-1/4 )
+c
+c    Avec  alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j)        
+c
+c    N.B .  Pour plus de details, voir s-pg  ...  iniconst ...
+c
+c
+c
+c   alpha4 .         . alpha1    . alpha4
+c    (i,j)             (i,j)       (i+1,j)
+c
+c             P .        U .          . P
+c           (i,j)       (i,j)         (i+1,j)
+c
+c   alpha3 .         . alpha2    .alpha3 
+c    (i,j)              (i,j)     (i+1,j)
+c
+c             V .        Z .          . V
+c           (i,j)
+c
+c   alpha4 .         . alpha1    .alpha4
+c   (i,j+1)            (i,j+1)   (i+1,j+1) 
+c
+c             P .        U .          . P
+c          (i,j+1)                    (i+1,j+1)
+c
+c
+c
+c
+c                       On  a :
+c
+c    pbarx(i,j) = Pext(i  ,j) * ( alpha1(i  ,j) + alpha2(i,j))      +
+c                 Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) )
+c     localise  au point  ... U (i,j) ...
+c
+c    pbary(i,j) = Pext(i,j  ) * ( alpha2(i,j  ) + alpha3(i,j  )     +
+c                 Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1)  
+c     localise  au point  ... V (i,j) ...
+c
+c  pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) +
+c               Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1)
+c     localise  au point  ... Z (i,j) ...
+c
+c
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+      REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 )
+
+      INTEGER  l, ij
+      EXTERNAL SCOPY
+c
+
+      DO ij = 1, ip1jmp1
+       pext(ij) = ps(ij) * aire(ij)
+      ENDDO
+
+
+      DO     5     ij = 1, ip1jm - 1
+      psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) +
+     *   pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2)
+   5  CONTINUE
+
+
+c    ....  correction pour     psexbarxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+      DO 7 ij = iip1, ip1jm, iip1
+      psexbarxy( ij ) = psexbarxy( ij - iim )
+   7  CONTINUE
+
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/q_sat.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/q_sat.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/q_sat.F	(revision 428)
@@ -0,0 +1,59 @@
+      FUNCTION q_sat(kelvin, millibar)
+c
+      IMPLICIT none
+c======================================================================
+c Autheur(s): Z.X. Li (LMD/CNRS)
+c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+c======================================================================
+c Arguments:
+c kelvin---input-R: temperature en Kelvin
+c millibar--input-R: pression en mb
+c
+c q_sat----output-R: vapeur d'eau saturante en kg/kg
+c======================================================================
+c
+      REAL q_sat, kelvin, millibar
+c
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+c
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+c
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+c
+      REAL rtt
+      PARAMETER (rtt=273.16)
+c
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+c
+      REAL zqsat
+      REAL temp, pres
+C     ------------------------------------------------------------------
+c
+c
+      temp = kelvin
+      pres = millibar * 100.0
+c      write(*,*)'kelvin,millibar=',kelvin,millibar
+c      write(*,*)'temp,pres=',temp,pres
+c
+      IF (temp .LE. rtt) THEN
+         r3es = r3ies
+         r4es = r4ies
+      ELSE
+         r3es = r3les
+         r4es = r4les
+      ENDIF
+c
+      zqsat=r2es/pres * EXP ( r3es*(temp-rtt) / (temp-r4es) )
+      zqsat=MIN(0.5,ZQSAT)
+      zqsat=zqsat/(1.-retv  *zqsat)
+c
+      q_sat = zqsat
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/qminimum.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/qminimum.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/qminimum.F	(revision 428)
@@ -0,0 +1,83 @@
+      SUBROUTINE qminimum( q,nq,deltap )
+
+      IMPLICIT none
+c
+c  -- Objet : Traiter les valeurs trop petites (meme negatives)
+c             pour l'eau vapeur et l'eau liquide
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+c
+      INTEGER nq
+      REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm)
+c
+      INTEGER iq_vap, iq_liq
+      PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur
+      PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide
+      REAL seuil_vap, seuil_liq
+      PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur
+      PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide
+c
+c  NB. ....( Il est souhaitable mais non obligatoire que les valeurs des
+c            parametres seuil_vap, seuil_liq soient pareilles a celles 
+c            qui  sont utilisees dans la routine    ADDFI       )
+c     .................................................................
+c
+      INTEGER i, k, iq
+      REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe
+c
+      REAL SSUM
+      EXTERNAL SSUM
+c
+      INTEGER imprim
+      SAVE imprim
+      DATA imprim /0/
+c
+c Quand l'eau liquide est trop petite (ou negative), on prend
+c l'eau vapeur de la meme couche et la convertit en eau liquide
+c (sans changer la temperature !)
+c
+      DO 1000 k = 1, llm
+      DO 1040 i = 1, ip1jmp1
+            zx_defau      = AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 )
+            q(i,k,iq_vap) = q(i,k,iq_vap) - zx_defau
+            q(i,k,iq_liq) = q(i,k,iq_liq) + zx_defau
+ 1040 CONTINUE
+ 1000 CONTINUE
+c
+c Quand l'eau vapeur est trop faible (ou negative), on complete
+c le defaut en prennant de l'eau vapeur de la couche au-dessous.
+c
+      iq = iq_vap
+c
+      DO k = llm, 2, -1
+ccc      zx_abc = dpres(k) / dpres(k-1)
+      DO i = 1, ip1jmp1
+         zx_abc = deltap(i,k)/deltap(i,k-1)
+         zx_defau    = AMAX1( seuil_vap - q(i,k,iq), 0.0 )
+         q(i,k-1,iq) =  q(i,k-1,iq) - zx_defau * zx_abc
+         q(i,k,iq)   =  q(i,k,iq)   + zx_defau  
+      ENDDO
+      ENDDO
+c
+c Quand il s'agit de la premiere couche au-dessus du sol, on
+c doit imprimer un message d'avertissement (saturation possible).
+c
+      DO i = 1, ip1jmp1
+         zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) )
+         q(i,1,iq)  = AMAX1( q(i,1,iq), seuil_vap )
+      ENDDO
+      pompe = SSUM(ip1jmp1,zx_pump,1)
+      IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN
+         WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe
+         DO i = 1, ip1jmp1
+            IF (zx_pump(i).GT.0.0) THEN
+               imprim = imprim + 1
+               PRINT*,'  en ',i,zx_pump(i)
+            ENDIF
+         ENDDO
+      ENDIF
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ran1.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ran1.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/ran1.F	(revision 428)
@@ -0,0 +1,31 @@
+      FUNCTION RAN1(IDUM)
+      DIMENSION R(97)
+      save r
+      save iff,ix1,ix2,ix3
+      PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6)
+      PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6)
+      PARAMETER (M3=243000,IA3=4561,IC3=51349)
+      DATA IFF /0/
+      IF (IDUM.LT.0.OR.IFF.EQ.0) THEN
+        IFF=1
+        IX1=MOD(IC1-IDUM,M1)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX2=MOD(IX1,M2)
+        IX1=MOD(IA1*IX1+IC1,M1)
+        IX3=MOD(IX1,M3)
+        DO 11 J=1,97
+          IX1=MOD(IA1*IX1+IC1,M1)
+          IX2=MOD(IA2*IX2+IC2,M2)
+          R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
+11      CONTINUE
+        IDUM=1
+      ENDIF
+      IX1=MOD(IA1*IX1+IC1,M1)
+      IX2=MOD(IA2*IX2+IC2,M2)
+      IX3=MOD(IA3*IX3+IC3,M3)
+      J=1+(97*IX3)/M3
+      IF(J.GT.97.OR.J.LT.1)PAUSE
+      RAN1=R(J)
+      R(J)=(FLOAT(IX1)+FLOAT(IX2)*RM2)*RM1
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_dstoke.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_dstoke.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_dstoke.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_fstoke0.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/read_pstoke.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_pstoke.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_pstoke.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/read_reanalyse.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_reanalyse.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/read_reanalyse.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/readhist.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/readhist.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/readhist.F	(revision 428)
@@ -0,0 +1,63 @@
+      SUBROUTINE readhist(typfile,unitlec,
+     s  ucov,vcov,h,pext,ptime,pdt,ifin)
+c%W%    %G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 11/11/92
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "comconst.h"
+#include "control.h"
+#include "paramet.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER typfile,unitlec
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),h(ip1jmp1,llm)
+      REAL pext(ip1jmp1)
+      REAL pdt,ptime
+
+c   Local:
+c   ------
+
+      INTEGER ifin
+
+c-----------------------------------------------------------------------
+
+      ifin=0
+      IF(typfile.EQ.0) THEN
+         READ(unitlec,err=9999) ptime,vcov,ucov,h,pext
+         pdt=iecri*dtvr
+      ELSE
+         READ(unitlec,err=9999) ptime,pdt,vcov,ucov,h,pext
+      ENDIF
+      PRINT*,ptime,pdt
+
+      RETURN
+9999  CONTINUE
+	  ifin=1
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/redecoupenc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/redecoupenc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/redecoupenc.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/reduce_i.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/reduce_i.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/reduce_i.F	(revision 428)
@@ -0,0 +1,47 @@
+      SUBROUTINE reduce_i(ni,nj,x,x_r)
+c%W%	%G%
+c=======================================================================
+c
+c   Author:    Frederic Hourdin      original: 14/02/93
+c   -------
+c
+c   Subject:
+c   ------
+c
+c   Method:
+c   --------
+c
+c   Interface:
+c   ----------
+c
+c      Input:
+c      ------
+c
+c      Output:
+c      -------
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+c   Arguments:
+c   ----------
+
+      INTEGER ni,nj
+      REAL x(ni+1,nj),x_r(ni,nj)
+
+c   Local:
+c   ------
+
+      INTEGER j
+      EXTERNAL SCOPY
+
+c-----------------------------------------------------------------------
+
+      DO j=1,nj
+	 CALL SCOPY(ni,x(1,j),1,x_r(1,j),1)
+      ENDDO
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat.F	(revision 428)
@@ -0,0 +1,55 @@
+      SUBROUTINE rotat (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+ccc        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat_nfil.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat_nfil.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotat_nfil.F	(revision 428)
@@ -0,0 +1,46 @@
+      SUBROUTINE rotat_nfil (klevel, x, y, rot )
+c
+c    Auteur :   P.Le Van 
+c**************************************************************
+c.          Calcule le rotationnel  non filtre   ,
+c      a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatf.F	(revision 428)
@@ -0,0 +1,55 @@
+      SUBROUTINE rotatf (klevel, x, y, rot )
+c
+c     Auteur : P.Le Van 
+c**************************************************************
+c.  calcule le rotationnel
+c     a tous les niveaux d'1 vecteur de comp. x et y ..
+c       x  et  y etant des composantes  covariantes  ...
+c********************************************************************
+c   klevel, x  et y   sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+c
+c   .....  variables en arguments  ......
+c
+      INTEGER klevel
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+c
+c  ...   variables  locales  ...
+c
+      INTEGER  l, ij
+c
+c
+      DO  10 l = 1,klevel
+c
+        DO   ij = 1, ip1jm - 1
+         rot( ij,l )  =    y( ij+1 , l )  -  y( ij,l )   +
+     *                   x(ij +iip1, l )  -  x( ij,l )  
+        ENDDO
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+        DO  ij = iip1, ip1jm, iip1
+         rot( ij,l ) = rot( ij -iim,l )
+        ENDDO
+c
+  10  CONTINUE
+
+        CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 )
+      
+        DO l = 1, klevel
+          DO ij = 1, ip1jm
+           rot(ij,l) = rot(ij,l) * unsairez(ij)
+          ENDDO
+        ENDDO
+c
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatst.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatst.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/rotatst.F	(revision 428)
@@ -0,0 +1,40 @@
+      SUBROUTINE rotatst (klevel,x, y, rot )
+c
+c  P. Le Van
+c
+c    *****************************************************************
+c     .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y ..
+c         x  et  y etant des composantes  covariantes  .....
+c    *****************************************************************
+c        x  et y     sont des arguments d'entree pour le s-prog
+c        rot          est  un argument  de sortie pour le s-prog
+c
+      IMPLICIT NONE
+c
+      INTEGER klevel
+#include "dimensions.h"
+#include "paramet.h"
+
+      REAL rot( ip1jm,klevel )
+      REAL x( ip1jmp1,klevel ), y( ip1jm,klevel )
+      INTEGER  l, ij
+c
+c
+      DO 5 l = 1,klevel
+c
+      DO 1 ij = 1, ip1jm - 1
+      rot( ij,l )  =  (  y( ij+1 , l )  -  y( ij,l )   +
+     *                 x(ij +iip1, l )  -  x( ij,l )  )
+   1  CONTINUE
+c
+c    .... correction pour rot( iip1,j,l)  ....
+c
+c    ....   rot(iip1,j,l)= rot(1,j,l) ...
+CDIR$ IVDEP
+      DO 2 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim,l )
+   2  CONTINUE
+c
+   5  CONTINUE
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/serre.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/serre.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/serre.h	(revision 428)
@@ -0,0 +1,9 @@
+c
+c $Header$
+c
+c..include serre.h
+c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sort.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sort.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sort.F	(revision 428)
@@ -0,0 +1,35 @@
+C
+C $Header$
+C
+      SUBROUTINE sort(n,d)
+c
+c     P.Le Van
+c      
+c...  cette routine met le tableau d  dans l'ordre croissant  ....
+cc   ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc
+c      tion  situee + bas  IF(d(j).LE.p)  THEN     par
+c                           IF(d(j).GE.p)  THEN
+c
+
+      INTEGER n
+      REAL d(n) , p
+      INTEGER i,j,k
+
+      DO i=1,n-1
+        k=i
+        p=d(i)
+        DO j=i+1,n
+         IF(d(j).LE.p) THEN
+           k=j
+           p=d(j)
+         ENDIF
+        ENDDO
+
+       IF(k.ne.i) THEN
+         d(k)=d(i)
+         d(i)=p
+       ENDIF
+      ENDDO
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc.F	(revision 428)
@@ -0,0 +1,164 @@
+      SUBROUTINE sortvarc
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      EXTERNAL  filtreg, massbarxy
+c     EXTERNAL FLUSH
+      EXTERNAL   SSUM, SCOPY 
+      REAL       SSUM
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       CALL multipl(ip1jmp1,dp,dp,ge)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot  = SSUM(     llm, etotl, 1 )
+      ztot  = SSUM(     llm, ztotl, 1 )
+      stot  = SSUM(     llm, stotl, 1 )
+      rmsv  = SSUM(     llm, rmsvl, 1 )
+      ang   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      IF(ptot0.eq.0.)  THEN
+         PRINT 3500, itau, rday, heure,time
+         PRINT*,'WARNING!!! On recalcule les valeurs initiales de :'
+         PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang'
+         PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+         etot0 = etot
+         ptot0 = ptot
+         ztot0 = ztot
+         stot0 = stot
+         ang0  = ang
+      END IF
+
+      etot= etot/etot0
+      rmsv= SQRT(rmsv/ptot)
+      ptot= ptot/ptot0
+      ztot= ztot/ztot0
+      stot= stot/stot0
+      ang = ang /ang0
+
+
+      PRINT 3500, itau, rday, heure, time
+      PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang
+
+      RETURN
+
+3500   FORMAT('0'10(1h*),4x,'pas'i7,5x,'jour'f5.0,'heure'f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+4000   FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie'
+     * ,2x,'entropie',3x,'rmsv',4x,'mt.ang'/6x,f10.6,e13.6,5f10.3/
+     * )
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/sortvarc0.F	(revision 428)
@@ -0,0 +1,141 @@
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      EXTERNAL  filtreg, massbarxy
+c     EXTERNAL FLUSH
+      EXTERNAL   SSUM, SCOPY ,ismin,ismax
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       CALL multipl(ip1jmp1,dp,dp,ge)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = FLOAT(INT ( day_ini + time ))
+c
+      PRINT 3500, itau, rday, heure, time
+      PRINT *, ptot0,etot0,ztot0,stot0,ang0
+
+3500   FORMAT('0',10(1h*),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x 
+     *   ,'date',f10.5,4x,10(1h*))
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/spline.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/spline.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/spline.F	(revision 428)
@@ -0,0 +1,76 @@
+      subroutine spline(x,y,n,yp1,ypn,y2)
+     
+c
+     
+c     Routine to set up the interpolating function for a cubic spline
+     
+c     interpolation (see "Numerical Recipes" for details).
+     
+c
+	  implicit real (a-h,o-z)
+	  implicit integer (i-n)
+     
+      parameter(nllm=4096)
+     
+      dimension x(n),y(n),y2(n),u(nllm)
+     
+c
+c	write(6,*)(x(i),i=1,n)
+c	write(6,*)(y(i),i=1,n)
+     
+      if(yp1.gt.0.99E30) then
+c the lower boundary condition is set
+       y2(1)=0.
+c either to be "natural"
+       u(1)=0.
+     
+      else
+c or else to have a specified first
+       y2(1)=-0.5
+c derivative
+       u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+     
+      end if
+     
+      do 11 i=2,n-1
+c decomposition loop of the tridiagonal
+       sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+c algorithm. Y2 and U are used
+       p=sig*y2(i-1)+2.
+c for temporary storage of the decompo-
+       y2(i)=(sig-1.)/p
+c sed factors
+       u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))
+     
+     . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+     
+ 11   continue
+     
+      if(ypn.gt.0.99E30) then
+c the upper boundary condition is set
+       qn=0.
+c either to be "natural"
+       un=0.
+     
+      else
+c or else to have a specified first
+       qn=0.5
+c derivative
+       un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+     
+      end if
+     
+      y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+     
+      do 12 k=n-1,1,-1
+c this is the backsubstitution loop of
+       y2(k)=y2(k)*y2(k+1)+u(k)
+c the tridiagonal algorithm
+ 12   continue
+     
+c
+     
+      return
+     
+      end
+     
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/splint.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/splint.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/splint.F	(revision 428)
@@ -0,0 +1,53 @@
+     
+      SUBROUTINE splint(xa,ya,y2a,n,x,y)
+     
+c
+c     Routine to compute a cubic-spline interpolated value Y given the
+c     value of X, the arrays XA, YA and the 2nd derivative array Y2A
+c     computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details
+c
+     
+      IMPLICIT REAL (a-h,o-z)
+      IMPLICIT INTEGER (i-n)
+      DIMENSION xa(n),ya(n),y2a(n)
+     
+      kl0=1
+     
+      khi=n
+c means of bisection
+ 1    IF(khi-kl0.gt.1) THEN
+     
+       k=(khi+kl0)/2
+     
+       IF(xa(k).gt.x) THEN
+     
+        khi=k
+     
+       ELSE
+     
+        kl0=k
+     
+       END IF
+     
+       GO TO 1
+     
+      END IF
+c KL0 and KHI now bracket the X
+      h=xa(khi)-xa(kl0)
+     
+      IF(h.eq.0.0) STOP
+      a=(xa(khi)-x)/h
+c evaluation of cubic spline polynomial
+      b=(x-xa(kl0))/h
+     
+      y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2)
+     
+     ./6.
+     
+c
+     
+      RETURN
+     
+      END
+     
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/startvar.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/startvar.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/startvar.F	(revision 428)
@@ -0,0 +1,1172 @@
+C
+C $Header$
+C
+      MODULE startvar
+    !
+    !
+    !      There are three ways to access data from the database of atmospheric data which 
+    !       can be used to initialize the model. This depends on the type of field which needs 
+    !       to be extracted. In any case the call should come after a restget and should be of the type :
+    !                CALL startget(...)
+    !
+    !       We will details the possible arguments to startget here :
+    !
+    !        - A 2D variable on the dynamical grid :
+    !           CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar )             
+    !
+    !        - A 1D variable on the physical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         - A 3D variable on the dynamical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar )
+    !
+    !
+    !         There is special constraint on the atmospheric data base except that the 
+    !         the data needs to be in netCDF and the variables should have the the following 
+    !        names in the file :
+    !
+    !      'RELIEF'  : High resolution orography 
+    !       'ST'            : Surface temperature
+    !       'CDSW'     : Soil moisture
+    !       'Z'               : Surface geopotential
+    !       'SP'            : Surface pressure
+    !        'U'              : East ward wind
+    !        'V'              : Northward wind
+    !        'TEMP'             : Temperature
+    !        'R'             : Relative humidity
+    !      
+      USE ioipsl
+    !
+    !
+      IMPLICIT NONE
+    !
+    !
+      PRIVATE
+      PUBLIC startget
+    !
+    !
+      INTERFACE startget
+        MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn
+      END INTERFACE
+    !
+      INTEGER, SAVE :: fid_phys, fid_dyn
+      INTEGER, SAVE  :: iml_phys, iml_rel, iml_dyn
+      INTEGER, SAVE :: jml_phys,  jml_rel, jml_dyn
+      INTEGER, SAVE ::  llm_dyn, ttm_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lon_phys, lon_rug,
+     . lon_alb, lon_rel, lon_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: lat_phys, lat_rug,
+     . lat_alb, lat_rel, lat_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:)  :: levdyn_ini
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: relief, zstd, zsig,
+     . zgam, zthe, zpic, zval
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: rugo, masque, phis
+    !
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:)  :: tsol, qsol, psol_dyn
+      REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:)  ::   var_ana3d
+    !
+      CONTAINS
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in,
+     . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu )
+    !
+    !    There is a big mess with the size in logitude, should it be iml or iml+1.
+    !    I have chosen to use the iml+1 as an argument to this routine and we declare
+    !   internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. 
+    !  A convention is required.
+    !
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(iml,jml)
+      REAL, INTENT(in) :: val_exp
+      REAL, INTENT(in), optional :: masque_lu(iml,jml) 
+      LOGICAL interbar
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. 
+     .MINVAL(champ(:,:)).EQ.val_exp ) THEN
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('relief')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(relief)) THEN
+                      !
+                    if (present(masque_lu)) then
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar, masque_lu )
+                    else
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2, interbar)
+                    endif
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(relief) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 'STARTVAR module has been',
+     .' initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = relief(:,:)
+                  !
+              CASE ('rugosite')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(rugo)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                    jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(rugo) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = rugo(:,:)
+                  !
+              CASE ('masque')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(masque)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                     jml2,lon_in2,lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(masque) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*) 
+     .   'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = masque(:,:)
+                  !
+              CASE ('surfgeo')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = phis(:,:)
+                  !
+              CASE ('psol')
+                  !
+                  !  If we do not have the orography we need to get it
+                  !
+                  IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                      !
+                      CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .                   jml2,lon_in2, lat_in2 , interbar )
+                      !
+                  ENDIF
+                  !
+                  IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  champ(:,:) = psol_dyn(:,:)
+                  !
+              CASE DEFAULT
+                  !
+                  WRITE(*,*) 'startget_phys2d'
+                  WRITE(*,*) 'No rule is present to extract variable', 
+     .                 varname(:LEN_TRIM(varname)),' from any data set'
+                  STOP
+                  !
+          END SELECT
+          !
+      ELSE
+          !
+          ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we
+          ! will catch them
+          !
+          SELECTCASE(varname)
+              !
+              CASE ('surfgeo')
+                  !
+                  IF ( .NOT.ALLOCATED(phis)) THEN
+                      ALLOCATE(phis(iml,jml))
+                  ENDIF
+                  !
+                  IF (SIZE(phis) .NE. SIZE(champ)) THEN
+                      !
+                      WRITE(*,*)
+     .  'STARTVAR module has been initialized to the wrong size'
+                      STOP
+                      !
+                  ENDIF
+                  !
+                  phis(:,:) = champ(:,:)
+                  !
+          END SELECT
+          !
+      ENDIF
+    !
+      END SUBROUTINE startget_phys2d
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 ,
+     ,   lat_in2 , interbar, masque_lu )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, intent(in), optional :: masque_lu(iml,jml)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      LOGICAL interbar2
+      REAL :: lev(1), date, dt,chmin,chmax
+      INTEGER :: itau(1), fid
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+      INTEGER :: iret
+      CHARACTER*25 title
+      REAL, ALLOCATABLE :: relief_hi(:,:)
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: tmp_var(:,:)
+      INTEGER, ALLOCATABLE :: tmp_int(:,:)
+    !
+      CHARACTER*120 :: orogfname
+      LOGICAL :: check=.TRUE.
+    !
+    !
+      orogfname = 'Relief.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Reading the high resolution orography'
+    !
+      CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid)
+    !
+      ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret)
+      ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret)
+    !
+      CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, 
+     .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp,
+     .      itau, date, dt, fid)
+    !
+      CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, 
+     . ttm_tmp, 1, 1, relief_hi)
+    !
+      CALL flinclo(fid)
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_rel))
+      ALLOCATE(lon_ini(iml_rel))
+
+      IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_rel(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_rel))
+      ALLOCATE(lat_ini(jml_rel))
+
+      IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_rel(1,:) 
+      ENDIF
+    !
+    !
+
+      title='RELIEF'
+
+      interbar2 = .FALSE.
+      CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini,
+     . lon_rad, lat_rad, relief_hi , interbar2  )
+
+      IF ( check ) WRITE(*,*) 'Computes all the parameters needed',
+     .' for the gravity wave drag code'
+    !
+    !    Allocate the data we need to put in the interpolated fields
+    !
+    !            RELIEF:  orographie moyenne
+      ALLOCATE(relief(iml,jml))
+    !            zphi :  orographie moyenne
+      ALLOCATE(phis(iml,jml))
+    !             zstd:  deviation standard de l'orographie sous-maille
+      ALLOCATE(zstd(iml,jml))
+    !             zsig:  pente de l'orographie sous-maille 
+      ALLOCATE(zsig(iml,jml))
+    !             zgam:  anisotropy de l'orographie sous maille
+      ALLOCATE(zgam(iml,jml))
+    !             zthe:  orientation de l'axe oriente dans la direction
+    !                    de plus grande pente de l'orographie sous maille
+      ALLOCATE(zthe(iml,jml))
+    !             zpic:  hauteur pics de la SSO
+      ALLOCATE(zpic(iml,jml))
+    !             zval:  hauteur vallees de la SSO
+      ALLOCATE(zval(iml,jml))
+    !             masque : Masque terre ocean
+      ALLOCATE(tmp_int(iml,jml))
+      ALLOCATE(masque(iml,jml))
+
+      masque = -99999.
+      if (present(masque_lu)) then
+        masque = masque_lu
+      endif
+    !
+      CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, 
+     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque)
+      phis = phis * 9.81
+    !
+!      masque(:,:) = FLOAT(tmp_int(:,:))
+    !
+    !  Compute surface roughness
+    !
+      IF ( check ) WRITE(*,*) 
+     .'Compute surface roughness induced by the orography'
+    !
+      ALLOCATE(rugo(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, tmp_var)
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          rugo(i,j) = tmp_var(i,j)
+        ENDDO
+        rugo(iml,j) = tmp_var(1,j)
+      ENDDO
+c
+cc   ***   rugo  n'est pas utilise pour l'instant  ******
+    !
+    !   Build land-sea mask
+    !
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_orog
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, 
+     .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar)
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, nbindex, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(inout) :: champ(nbindex)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. 
+     .MINVAL(champ(:)).EQ.val_exp ) THEN
+          SELECTCASE(varname)
+            CASE ('tsol')
+              IF ( .NOT.ALLOCATED(tsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2, lat_in2, interbar )
+              ENDIF
+              IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ)
+            CASE ('qsol')
+              IF ( .NOT.ALLOCATED(qsol)) THEN
+                CALL start_init_phys( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ)
+            CASE ('psol')
+              IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+                CALL start_init_dyn( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN
+                WRITE(*,*) 
+     . 'STARTVAR module has been initialized to the wrong size'
+                STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ)
+            CASE ('zmea')
+              IF ( .NOT.ALLOCATED(relief)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ)
+            CASE ('zstd')
+              IF ( .NOT.ALLOCATED(zstd)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .              jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ)
+            CASE ('zsig')
+              IF ( .NOT.ALLOCATED(zsig)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .               jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ)
+            CASE ('zgam')
+              IF ( .NOT.ALLOCATED(zgam)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ)
+            CASE ('zthe')
+              IF ( .NOT.ALLOCATED(zthe)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ)
+            CASE ('zpic')
+              IF ( .NOT.ALLOCATED(zpic)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ)
+            CASE ('zval')
+              IF ( .NOT.ALLOCATED(zval)) THEN
+                CALL start_init_orog( iml, jml, lon_in, lat_in,
+     .            jml2, lon_in2,lat_in2 , interbar )
+              ENDIF
+              IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN
+                WRITE(*,*)
+     . 'STARTVAR module has been initialized to the wrong size'
+                 STOP
+              ENDIF
+              CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ)
+            CASE ('rads')
+                  champ(:) = 0.0
+            CASE ('snow')
+                  champ(:) = 0.0
+            CASE ('deltat')
+                  champ(:) = 0.0
+            CASE ('rugmer')
+                  champ(:) = 0.001
+            CASE ('agsno')
+                  champ(:) = 50.0
+            CASE DEFAULT
+              WRITE(*,*) 'startget_phys1d'
+              WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+              STOP
+          END SELECT
+      ELSE
+        !
+        ! If we see tsol we catch it as we may need it for a 3D interpolation
+        !
+        SELECTCASE(varname)
+          CASE ('tsol')
+            IF ( .NOT.ALLOCATED(tsol)) THEN
+              ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) ))
+            ENDIF
+            CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol)
+        END SELECT
+      ENDIF
+      END SUBROUTINE startget_phys1d
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2,
+     .                 lon_in2, lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml ,jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+    !
+      CHARACTER*25 title
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:)
+    !
+      physfname = 'ECPHY.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp,
+     . ttm_tmp, fid_phys)
+    !
+    !
+      ALLOCATE (lat_phys(iml_phys,jml_phys))
+      ALLOCATE (lon_phys(iml_phys,jml_phys))
+    !
+      CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, 
+     . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, 
+     . itau, date, dt, fid_phys)
+    !
+    ! Allocate the space we will need to get the data out of this file
+    !
+      ALLOCATE(var_ana(iml_phys, jml_phys))
+    !
+    !   In case we have a file which is in degrees we do the transformation
+    !
+      ALLOCATE(lon_rad(iml_phys))
+      ALLOCATE(lon_ini(iml_phys))
+
+      IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_phys(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_phys))
+      ALLOCATE(lat_ini(jml_phys))
+
+      IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_phys(1,:) 
+      ENDIF
+
+
+    !
+    !   We get the two standard varibales
+    !   Surface temperature
+    !
+      ALLOCATE(tsol(iml,jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+    !
+
+      CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, 
+     .llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='ST'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana , interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  ST $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var   ) 
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, tsol, iml-1, jml)
+    !
+    ! Soil moisture
+    !
+      ALLOCATE(qsol(iml,jml))
+      CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys,
+     . llm_tmp, ttm_tmp, 1, 1, var_ana)
+
+      title='CDSW'
+      CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  CDSW $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad ,
+     ,   var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var  )
+      ELSE
+        CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     .    var_ana, iml-1, jml, lon_in, lat_in, tmp_var     )
+      ENDIF
+c
+        CALL gr_int_dyn(tmp_var, qsol, iml-1, jml)
+    !
+       CALL flinclo(fid_phys)
+    !
+      END SUBROUTINE start_init_phys
+    !
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+    !
+      SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in,
+     . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 ,
+     ,  interbar )
+    !
+    !   ARGUMENTS
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, lml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      REAL, INTENT(in) :: pls(iml, jml, lml)
+      REAL, INTENT(in) :: workvar(iml, jml, lml)
+      REAL, INTENT(inout) :: champ(iml, jml, lml)
+      REAL, INTENT(in) :: val_exp
+      LOGICAL interbar
+    !
+    !    LOCAL
+    !
+      INTEGER :: il, ij, ii
+      REAL :: xppn, xpps
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+#include "comconst.h"
+    !
+    !   This routine only works if the variable does not exist or is constant
+    !
+      IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND.
+     . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN
+        !
+        SELECTCASE(varname)
+          CASE ('u')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .          lon_in2,lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('U', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ,interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('v')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, 
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('V', iml, jml, lml, lon_in, 
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            DO il=1,lml
+              DO ij=1,jml
+                DO ii=1,iml-1
+                  champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij)
+                ENDDO
+                champ(iml,ij, il) = champ(1,ij, il)
+              ENDDO
+            ENDDO
+          CASE ('t')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 ,interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+ 
+          CASE ('tpot')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 ,
+     .            lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .       lat_in, jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) )
+     .                                    THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = champ(ii,ij,il) * cpp 
+     .                                 / workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute potential temperature as the'
+              WRITE(*,*)'Exner function is missing or constant.'
+              STOP
+            ENDIF
+          CASE ('q')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 ,
+     .           lon_in2, lat_in2 , interbar )
+            ENDIF
+            CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in,
+     .        jml2, lon_in2, lat_in2,  pls, champ, interbar )
+            IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) 
+     .                                     THEN
+              DO il=1,lml
+                DO ij=1,jml
+                  DO ii=1,iml-1
+                    champ(ii,ij,il) = 0.01 * champ(ii,ij,il) *
+     .                                       workvar(ii,ij,il)
+                  ENDDO
+                  champ(iml,ij,il) = champ(1,ij,il)
+                ENDDO
+              ENDDO
+              WHERE ( champ .LT. 0.) champ = 1.0E-10
+              DO il=1,lml
+                xppn = SUM(aire(:,1)*champ(:,1,il))/apoln
+                xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols
+                champ(:,1,il) = xppn
+                champ(:,jml,il) = xpps
+              ENDDO
+            ELSE
+              WRITE(*,*)'Could not compute specific humidity as the'
+              WRITE(*,*)'saturated humidity is missing or constant.'
+              STOP
+            ENDIF
+          CASE DEFAULT
+            WRITE(*,*) 'startget_dyn'
+            WRITE(*,*) 'No rule is present to extract variable  ',
+     . varname(:LEN_TRIM(varname)),' from any data set'
+            STOP
+          END SELECT
+      ENDIF
+      END SUBROUTINE startget_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 ,
+     ,             lat_in2 , interbar )
+    !
+      INTEGER, INTENT(in) :: iml, jml, jml2
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2)
+      LOGICAL interbar
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER :: i, j
+      integer :: iret
+    !
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:)
+      REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:)
+      REAL, ALLOCATABLE :: xppn(:), xpps(:)
+      LOGICAL :: allo
+    !
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+
+      CHARACTER*25 title
+
+    !
+      physfname = 'ECDYN.nc'
+    !
+      IF ( check ) WRITE(*,*) 'Opening the surface analysis'
+    !
+      CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn,
+     .                            ttm_dyn, fid_dyn)
+      IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, 
+     .                                         llm_dyn, ttm_dyn
+    !
+      ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret)
+      ALLOCATE (levdyn_ini(llm_dyn), stat=iret)
+    !
+      CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn,
+     . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, 
+     . itau, date, dt, fid_dyn)
+    !
+
+      allo = allocated (var_ana)
+      if (allo) then
+        DEALLOCATE(var_ana, stat=iret)
+      endif
+      ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret)
+
+      allo = allocated (lon_rad)
+      if (allo) then
+        DEALLOCATE(lon_rad, stat=iret)
+      endif
+
+      ALLOCATE(lon_rad(iml_dyn), stat=iret)
+      ALLOCATE(lon_ini(iml_dyn))
+       
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+
+      ALLOCATE(z(iml, jml))
+      ALLOCATE(tmp_var(iml-1,jml))
+    !
+      CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+c
+      title='Z'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+c
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  Z  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, z, iml-1, jml)
+    !
+      ALLOCATE(psol_dyn(iml, jml))
+    !
+      CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn,
+     .              1, 1, var_ana)
+
+       title='SP'
+      CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini,
+     . lon_rad, lat_rad, var_ana, interbar  )
+
+      IF ( interbar )   THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour  SP  $$$ '
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad ,
+     ,    var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) 
+      ELSE
+        CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .             iml-1, jml, lon_in, lat_in, tmp_var  )
+      ENDIF
+
+      CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml)
+    !
+      IF ( .NOT.ALLOCATED(tsol)) THEN
+    !   These variables may have been allocated by the need to 
+    !   create a start field for them or by the varibale
+    !   coming out of the restart file. In case we dor have it we will initialize it.
+    !
+        CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2,
+     .                 lat_in2 , interbar )
+      ELSE
+        IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN
+        WRITE(*,*) 'start_init_dyn :'
+        WRITE(*,*) 'The temperature field we have does not ',
+     .             'have the right size'
+        STOP
+      ENDIF
+      ENDIF
+      IF ( .NOT.ALLOCATED(phis)) THEN
+            !
+            !    These variables may have been allocated by the need to create a start field for them or by the varibale
+            !     coming out of the restart file. In case we dor have it we will initialize it.
+            !
+        CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 ,
+     .      lat_in2 , interbar )
+            !
+      ELSE
+            !
+          IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN
+                !
+              WRITE(*,*) 'start_init_dyn :'
+              WRITE(*,*) 'The orography field we have does not ',
+     .                   ' have the right size'
+              STOP
+          ENDIF
+            !
+      ENDIF
+    !
+    !     PSOL is computed in Pascals
+    !
+    !
+      DO j = 1, jml
+        DO i = 1, iml-1
+          psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) 
+     .                    /287.0/tsol(i,j))
+        ENDDO
+        psol_dyn(iml,j) = psol_dyn(1,j)
+      ENDDO
+    !
+    !
+      ALLOCATE(xppn(iml-1))
+      ALLOCATE(xpps(iml-1)) 
+    !
+      DO  i   = 1, iml-1
+        xppn(i) = aire( i,1) * psol_dyn( i,1)
+        xpps(i) = aire( i,jml) * psol_dyn( i,jml)
+      ENDDO
+    !
+      DO i   = 1, iml
+        psol_dyn(i,1    )  = SUM(xppn)/apoln
+        psol_dyn(i,jml)  = SUM(xpps)/apols
+      ENDDO
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_dyn
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in,
+     .      lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar )
+    !
+    !    This subroutine gets a variables from a 3D file and does the interpolations needed
+    !
+    !
+    !    ARGUMENTS
+    !
+      CHARACTER*(*) :: varname
+      INTEGER :: iml, jml, lml, jml2
+      REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml)
+      REAL :: lon_in2(iml) , lat_in2(jml2)
+      REAL :: var3d(iml, jml, lml)
+      LOGICAL interbar
+      real chmin,chmax
+    !
+    !  LOCAL
+    !
+      CHARACTER*25 title
+      INTEGER :: ii, ij, il, jsort,i,j,l
+      REAL :: bx, by
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:)
+      REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:)
+      REAL, ALLOCATABLE :: ax(:), ay(:), yder(:)
+       REAL, ALLOCATABLE :: varrr(:,:,:)
+      INTEGER, ALLOCATABLE :: lind(:)
+    !
+      LOGICAL :: check = .TRUE.
+    !
+      IF ( .NOT. ALLOCATED(var_ana3d)) THEN
+          ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn))
+      ENDIF
+          ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn))
+    !
+    !
+      IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ',
+     .  ' field.', fid_dyn
+      IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn,
+     .                        llm_dyn,ttm_dyn
+    !
+      CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, 
+     . ttm_dyn, 1, 1, var_ana3d)
+    !
+      IF ( check) WRITE(*,*) 'Allocating space for the interpolation',
+     . iml, jml, llm_dyn
+    !
+      ALLOCATE(lon_rad(iml_dyn))
+      ALLOCATE(lon_ini(iml_dyn))
+
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_ini(:) = lon_dyn(:,1) 
+      ENDIF
+
+      ALLOCATE(lat_rad(jml_dyn))
+      ALLOCATE(lat_ini(jml_dyn))
+
+      ALLOCATE(lev_dyn(llm_dyn))
+
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_ini(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+
+      CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, 
+     . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d  ,
+     ,  interbar                                                   )
+
+      ALLOCATE(var_tmp2d(iml-1, jml))
+      ALLOCATE(var_tmp3d(iml, jml, llm_dyn))
+      ALLOCATE(ax(llm_dyn))
+      ALLOCATE(ay(llm_dyn))
+      ALLOCATE(yder(llm_dyn))
+      ALLOCATE(lind(llm_dyn))
+    !
+ 
+      DO il=1,llm_dyn
+        !
+      IF( interbar )  THEN
+       IF( il.EQ.1 )  THEN
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+        WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
+     , ' pour ', varname
+        WRITE(6,*) '-------------------------------------------------',
+     ,'--------------'
+       ENDIF
+       CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, 
+     , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) 
+      ELSE
+       CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, 
+     .  var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d )
+      ENDIF
+        !
+        CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml)
+        !
+       ENDDO
+       !
+          DO il=1,llm_dyn
+            lind(il) = llm_dyn-il+1
+          ENDDO
+    !
+c
+c  ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere
+c                    vers  le  sol  ...
+c
+      DO ij=1,jml
+        DO ii=1,iml-1
+          !
+          ax(:) = lev_dyn(lind(:)) 
+          ay(:) = var_tmp3d(ii, ij, lind(:))
+          !
+         
+          CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder)
+          !
+          DO il=1,lml
+            bx = pls_in(ii, ij, il)
+            CALL SPLINT(ax, ay, yder, llm_dyn, bx, by)
+            var3d(ii, ij, il) = by
+          ENDDO
+          !
+        ENDDO
+        var3d(iml, ij, :) = var3d(1, ij, :) 
+      ENDDO
+
+      do il=1,lml
+        call minmax(iml*jml,var3d(1,1,il),chmin,chmax)
+      SELECTCASE(varname)
+       CASE('U')
+          WRITE(*,*) ' U  min max l ',il,chmin,chmax
+       CASE('V')
+          WRITE(*,*) ' V  min max l ',il,chmin,chmax
+       CASE('TEMP')
+          WRITE(*,*) ' TEMP  min max l ',il,chmin,chmax
+       CASE('R')
+          WRITE(*,*) ' R  min max l ',il,chmin,chmax
+      END SELECT
+           enddo
+
+      DEALLOCATE(lon_rad)
+      DEALLOCATE(lat_rad)
+      DEALLOCATE(var_tmp2d)
+      DEALLOCATE(var_tmp3d)
+      DEALLOCATE(ax)
+      DEALLOCATE(ay)
+      DEALLOCATE(yder)
+      DEALLOCATE(lind)
+
+    !
+      RETURN
+    !
+      END SUBROUTINE start_inter_3d
+    !
+      END MODULE startvar
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/substr.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/substr.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/substr.F	(revision 428)
@@ -0,0 +1,14 @@
+      SUBROUTINE substr(np,px,py,pz)
+      IMPLICIT NONE
+
+      INTEGER np
+      REAL px(np),py(np),pz(np)
+
+      INTEGER i
+
+      DO i=1,np
+	 pz(i)=px(i)-py(i)
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.h	(revision 428)
@@ -0,0 +1,14 @@
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref,
+     .             itau_dyn, itau_phy
+
+      INTEGER   itaufin
+      INTEGER*4 itau_dyn, itau_phy
+      INTEGER*4 day_ini, day_end, annee_ref, day_ref
+      REAL      dt
+
+!-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/temps.inc	(revision 428)
@@ -0,0 +1,15 @@
+!
+! $Header$
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin, dt, &
+     &  day_ini, day_end, annee_ref, day_ref, itau_dyn, itau_phy
+
+      INTEGER  itaufin
+      INTEGER*4 itau_dyn, itau_phy
+      INTEGER*4 day_ini, day_end, annee_ref, day_ref
+      REAL     dt
+
+!-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/test_period.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/test_period.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/test_period.F	(revision 428)
@@ -0,0 +1,85 @@
+      SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis )
+c
+c     Auteur : P. Le Van  
+c    ---------
+c  ....  Cette routine teste la periodicite en longitude des champs   ucov,
+c                           teta, q , p et phis                 .......... 
+c
+c     IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+c
+c    ......  Arguments   ......
+c
+      REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) ,
+     ,      q(ip1jmp1,llm,nqmx), p(ip1jmp1,llmp1), phis(ip1jmp1)
+c
+c   .....  Variables  locales  .....
+c
+      INTEGER ij,l,nq
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( ucov(ij,l).NE.ucov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  UCOV  ---  n est pas',  
+     ,  ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( teta(ij,l).NE.teta(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  TETA  ---  n est pas',  
+     ,   ' periodique en longitude ! '
+          PRINT *,' l,  ij = ', l, ij, ij+iim
+          STOP
+          ENDIF
+         ENDDO
+      ENDDO
+
+c
+      DO l = 1, llm
+         DO ij = 1, ip1jm, iip1
+          IF( vcov(ij,l).NE.vcov(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  VCOV  ---  n est pas',  
+     ,   ' periodique en longitude !'
+          PRINT *,' l,  ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l)
+          vcov(ij+iim,l)=vcov(ij,l)
+c         STOP
+          ENDIF
+         ENDDO
+      ENDDO
+      
+c
+      DO nq =1, nqmx
+        DO l =1, llm
+          DO ij = 1, ip1jmp1, iip1
+          IF( q(ij,l,nq).NE.q(ij+iim,l,nq) )  THEN
+          PRINT *,'STOP dans test_period car ---  Q  ---  n est pas ',  
+     ,   'periodique en longitude !'
+          PRINT *,' nq , l,  ij = ', nq, l, ij, ij+iim
+          STOP
+          ENDIF
+          ENDDO
+        ENDDO
+      ENDDO
+c
+       DO l = 1, llm
+         DO ij = 1, ip1jmp1, iip1
+          IF( p(ij,l).NE.p(ij+iim,l) )  THEN
+          PRINT *,'STOP dans test_period car ---  P  ---  n est pas',  
+     ,    ' periodique en longitude !'
+          PRINT *,' l ij = ',l, ij, ij+iim
+          STOP
+          ENDIF
+          IF( phis(ij).NE.phis(ij+iim) )  THEN
+          PRINT *,'STOP dans test_period car ---  PHIS  ---  n est pas',  
+     ,   ' periodique en longitude !  l, IJ = ', l, ij,ij+iim
+          PRINT *,' ij = ', ij, ij+iim
+          STOP
+          ENDIF
+         ENDDO
+       ENDDO
+c
+c
+         RETURN
+         END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/testharm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/testharm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/testharm.F	(revision 428)
@@ -0,0 +1,44 @@
+      PROGRAM testharm
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      integer i,j,ii,jj
+      real pi
+      real psi(jjp1,jjp1,iim) , fphi(iim,iim)
+      character file*20, str2*2, str2b*2
+
+#include "serre.h"
+#include "fxyprim.h"
+
+      pi=2.*asin(1.)
+
+      call harmspher( fphi,psi )
+      print*,'FIN de harmspher'
+
+      do i=1,iim
+         write(str2,'(i2.2)') i
+         file='Phi'//str2
+         open(10,file=file,form='formatted')
+         print*,'i,file',i,file
+         do ii=1,iim
+            write(10,*) fx(float(ii))*180./pi,fphi(ii,i)
+         enddo
+         close(10)
+      enddo
+
+      do i=1,iim
+         do j=1,jjp1
+            write(str2,'(i2.2)') i
+            write(str2b,'(i2.2)') j
+            file='Psi.'//str2//'.'//str2b
+            open(10,file=file,form='formatted')
+            do jj=1,jjp1
+               write(10,*) fy(float(jj))*180./pi,psi(jj,j,i)
+            enddo
+            close(10)
+         enddo
+      enddo
+
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tourpot.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tourpot.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tourpot.F	(revision 428)
@@ -0,0 +1,79 @@
+      SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c    .........      calcul du tourbillon potentiel             .........
+c    *******************************************************************
+c
+c     vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg .
+c             vorpot            est  un argum.de sortie pour le s-pg .
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "logic.h"
+
+      REAL  rot( ip1jm,llm )
+      REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm )
+      REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm )
+
+      INTEGER l, ij
+
+      EXTERNAL filtreg
+
+
+
+c  ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy ..
+
+
+
+c    ........  Calcul du rotationnel du vent V  puis filtrage  ........
+
+      DO 5 l = 1,llm
+
+      DO 2 ij = 1, ip1jm - 1
+      rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l)
+   2  CONTINUE
+
+c    ....  correction pour  rot( iip1,j,l )  .....
+c    ....     rot(iip1,j,l) = rot(1,j,l)    .....
+
+CDIR$ IVDEP
+
+      DO 3 ij = iip1, ip1jm, iip1
+      rot( ij,l ) = rot( ij -iim, l )
+   3  CONTINUE
+
+   5  CONTINUE
+
+
+      CALL  filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 )
+
+
+      DO 10 l = 1, llm
+
+      DO 6 ij = 1, ip1jm - 1
+      vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l)
+   6  CONTINUE
+
+c    ..... correction pour  vorpot( iip1,j,l)  .....
+c    ....   vorpot(iip1,j,l)= vorpot(1,j,l) ....
+CDIR$ IVDEP
+      DO 8 ij = iip1, ip1jm, iip1
+      vorpot( ij,l ) = vorpot( ij -iim,l )
+   8  CONTINUE
+
+  10  CONTINUE
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/traceur.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/traceur.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/traceur.F	(revision 428)
@@ -0,0 +1,81 @@
+      SUBROUTINE traceur (iq,iadv,q,teta,pk,w, pbaru, pbarv,dq )
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  F.Forget / A.Armengaud
+c   -------
+c
+c   ....  Modif  P.Le Van  ,  29/04/97  et 01/06/98    ....
+c
+c   ********************************************************************
+c   Transport des traceurs (dont l'humidite q(1)) par differents shemas
+c   ********************************************************************
+c     iq,q,pbaru et pbarv sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c     iadv = 1 :  Schema de transport type "humidite specifique  LMD"
+c                 (shema amont (horiz),moy arithmetique (vertic))
+c
+c     iadv = 2  :  Shema amont
+c
+c
+c     iadv = 0  : Indice montrant que q n'est pas vraiment un 
+c                traceur, mais une variable pronostique attachee
+c                (par exemple : une pente du shemas de pente)
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+c   Arguments:
+c   ----------
+      INTEGER iq,iadv(iq) 
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q( ip1jmp1,llm,iq), dq( ip1jmp1,llm,iq)
+      REAL w(ip1jmp1,llm),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      LOGICAL     qsat
+      PARAMETER ( qsat = .TRUE. )
+
+c
+cc ******     Si  iadv(iq) =  2   et   qsat = .TRUE.  ,   
+cc        ,  on choisit  le shema  amont avec le q sature   ********
+c
+
+      EXTERNAL adv_h2o, amont, amont_qsat
+
+
+       IF( iadv(iq).GT.2 )  THEN
+         PRINT *,' Erreur dans le choix de iadv  pour la routine 
+     *  traceur .  Corrigez . '
+         STOP
+       ENDIF
+
+c   ----------------------------------------------------------------
+c   Schema de transport type "humidite specifique  LMD" 
+c   (shema amont (horiz),moy arithmetique (vertic))
+c   ----------------------------------------------------------------
+         IF (iadv(iq).EQ.1) THEN
+              CALL adv_h2o (iq,iq,q,w, pbaru, pbarv,dq)       
+c   ----------------------------------------------------------------
+c   Shema amont (dans les 3 dimensions)
+c   ----------------------------------------------------------------
+         ELSE IF (iadv(iq).EQ.2) THEN
+           IF( qsat )   THEN
+              CALL amont_qsat ( iq,iq,q,teta,pk,w, pbaru, pbarv,dq )
+           ELSE
+              CALL amont      ( iq,iq,q,        w, pbaru, pbarv,dq )
+           ENDIF
+c   ----------------------------------------------------------------
+
+         ENDIF
+
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracstoke.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracstoke.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracstoke.h	(revision 428)
@@ -0,0 +1,2 @@
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracvl.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracvl.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/tracvl.F	(revision 428)
@@ -0,0 +1,128 @@
+      SUBROUTINE tracvl(numvanle,iapp_tracvl,nq,pbaru,pbarv ,
+     *                    p, masse , q, iapptrac, iadv1, teta, pk  )
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c                 F. Codron     (10/99)
+
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+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 ),teta(ip1jmp1,llm)
+      REAL pk(ip1jmp1,llm)
+
+c     ....  var. locales  .....
+c
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
+
+
+      INTEGER iadvtr, numvan
+      INTEGER ij,l,iq
+      REAL zdpmin, zdpmax
+      EXTERNAL  minmax
+      SAVE iadvtr, massem, pbaruc, pbarvc, numvan
+      DATA iadvtr/0/
+
+      numvan = numvanle
+
+      IF(iadvtr.EQ.0) THEN
+         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)
+         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)
+ccc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+c
+      ENDIF
+
+      iadvtr   = iadvtr+1
+      iapptrac = iadvtr
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+
+c  test sur l'eventuelle creation de valeurs negatives de la masse
+         DO l=1,llm-1
+            DO ij = iip2+1,ip1jm
+              zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l)
+     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
+     s                  +       wg(ij,l+1)  - wg(ij,l)
+            ENDDO
+            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+            DO ij = iip2,ip1jm
+               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+            ENDDO 
+
+
+            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+
+            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
+     s        '   MAX:', zdpmax
+            ENDIF
+
+         ENDDO
+
+c   Advection proprement dite.
+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
+
+         iadvtr=0
+
+c   on reinitialise a zero les flux de masse cumules.
+
+      ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vanleer.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vanleer.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vanleer.F	(revision 428)
@@ -0,0 +1,122 @@
+      SUBROUTINE vanleer(numvanle,iapp_tracvl,nq,q,pbaru,pbarv ,
+     *                     p ,masse, dq ,  iadv1, teta, pk      )
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c     F.Codron (10/99) : ajout humidite specifique pour eau vapeur
+c=======================================================================
+c
+c       Shema de  Van Leer
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+c   Arguments:
+c   ----------
+      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
+c  .. dq n'est utilise et dimensionne que pour l'eau  vapeur et liqu.
+c
+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
+c   Local:
+c   ------
+
+      EXTERNAL  tracvl,minmaxq, qminimum
+      INTEGER ij,l, iq, iapptrac
+      REAL finmasse(ip1jmp1,llm), dtvrtrac
+cc
+
+
+c .. Si numvanle = 1 , l'eau vapeur et l'eau liq. ont le shema Van-Leer .
+c
+      IF( numvanle.EQ.1 ) THEN
+
+        DO iq = 1, nq
+          DO l = 1, llm
+            DO ij = 1, ip1jmp1
+             dq(ij,l,iq ) = 0.
+            ENDDO
+          ENDDO
+        ENDDO
+
+        CALL SCOPY( 2 * ijp1llm, q, 1, dq, 1 )
+
+c  test des valeurs minmax
+cc        CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ')
+cc        CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ')
+      ENDIF
+
+c   advection
+
+      CALL tracvl( numvanle,iapp_tracvl,nq,pbaru,pbarv,p , masse,q  ,
+     *                      iapptrac, iadv1, teta ,pk              )
+
+      IF( numvanle.EQ.1 ) THEN
+c
+
+         IF( iapptrac.EQ.iapp_tracvl ) THEN
+c
+cc          CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur     ')
+cc          CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide    ')
+
+cc     ....  Calcul  de deltap  qu'on stocke dans finmasse   ...
+c
+          DO l = 1, llm
+           DO ij = 1, ip1jmp1
+             finmasse(ij,l) =  p(ij,l) - p(ij,l+1) 
+           ENDDO
+          ENDDO
+
+          CALL qminimum( q, 2, finmasse )
+
+          CALL SCOPY   ( ip1jmp1*llm, masse, 1, finmasse,       1 )
+          CALL filtreg ( finmasse ,  jjp1,  llm, -2, 2, .TRUE., 1 )
+c
+c   *****  Calcul de dq pour l'eau , pour le passer a la physique ******
+c   ********************************************************************
+c
+          dtvrtrac = iapp_tracvl * dtvr
+c
+           DO iq = 1 , 2
+            DO l = 1 , llm
+             DO ij = 1,ip1jmp1
+             dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l)
+     *                               /  dtvrtrac
+             ENDDO
+            ENDDO
+           ENDDO
+c
+         ELSE
+           DO iq = 1 , 2
+           DO l  = 1, llm
+             DO ij = 1,ip1jmp1
+              dq(ij,l,iq)  = 0.
+             ENDDO
+           ENDDO
+           ENDDO
+
+         ENDIF
+c
+
+      ENDIF
+
+c
+c  ... On appelle  qminimum uniquement  pour l'eau vapeur et liquide  ..
+ 
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vitvert.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vitvert.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vitvert.F	(revision 428)
@@ -0,0 +1,49 @@
+      SUBROUTINE vitvert ( convm , w )
+c
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:  P. Le Van , F. Hourdin .
+c   -------
+c
+c   Objet:
+c   ------
+c
+c    *******************************************************************
+c  .... calcul de la vitesse verticale aux niveaux sigma  ....
+c    *******************************************************************
+c     convm   est un argument  d'entree pour le s-pg  ......
+c       w     est un argument de sortie pour le s-pg  ......
+c
+c    la vitesse verticale est orientee de  haut en bas .
+c    au sol, au niveau sigma(1),   w(i,j,1) = 0.
+c    au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi
+c    egale a 0. et n'est pas stockee dans le tableau w  .
+c
+c
+c=======================================================================
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+
+      REAL w(ip1jmp1,llm),convm(ip1jmp1,llm)
+      INTEGER   l, ij
+
+
+
+      DO 2  l = 1,llmm1
+
+      DO 1 ij = 1,ip1jmp1
+      w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 )
+   1  CONTINUE
+
+   2  CONTINUE
+
+      DO 5 ij  = 1,ip1jmp1
+      w(ij,1)  = 0.
+5     CONTINUE
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlsplt.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlsplt.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlsplt.F	(revision 428)
@@ -0,0 +1,955 @@
+      SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c   pente_max facteur de limitation des pentes: 2 en general
+c                                               0 pour un schema amont
+c   pbaru,pbarv,w flux de masse en u ,v ,w
+c   pdt pas de temps
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+c      REAL masse(iip1,jjp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+c      REAL q(iip1,jjp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+      INTEGER ijlqmin,iqmin,jqmin,lqmin
+c
+      REAL zm(ip1jmp1,llm),newmasse
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm),zz
+      REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm)
+      REAL second,temps0,temps1,temps2,temps3
+      REAL ztemps1,ztemps2,ztemps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+      INTEGER iminn,imaxx
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+      
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+c	print*,'Entree vlx1'
+c	call minmaxq(zq,qmin,qmax,'avant vlx     ')
+      call vlx(zq,pente_max,zm,mu)
+C	print*,'Sortie vlx1'
+c	call minmaxq(zq,qmin,qmax,'apres vlx1    ')
+
+C	 print*,'Entree vly1'
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly1     ')
+C	print*,'Sortie vly1'
+      call vlz(zq,pente_max,zm,mw)
+c	call minmaxq(zq,qmin,qmax,'apres vlz     ')
+
+
+      call vly(zq,pente_max,zm,mv)
+c	call minmaxq(zq,qmin,qmax,'apres vly     ')
+
+
+      call vlx(zq,pente_max,zm,mu)
+c	call minmaxq(zq,qmin,qmax,'apres vlx2    ')
+	
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlx(q,pente_max,masse,u_m)
+
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical extremum,first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+      REAL z1,z2,z3
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c       IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+C	print*,'Ok calcul des pentes'
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+c	 print*,'Bouclage en iip1'
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+C	print*,'Cumule ....'
+
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+Cc	print*,'masse(',ij,')=',masse(ij,l)
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+c	stop
+
+c	go to 9999
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+C	print*,'Ok test 1'
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+C	 print*,'Ok test 2'
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.1) THEN
+      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+9999    continue
+
+
+c   bouclage en latitude
+C	print*,'Avant bouclage en latitude'
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tENDances
+
+      DO l=1,llm
+         DO ij=iip2+1,ip1jm
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+      SUBROUTINE vly(q,pente_max,masse,masse_adv_v)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm), dq( ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical extremum,first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      real massepn,masseps,qpn,qps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+      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
+c	PRINT*,'CALCUL EN LATITUDE'
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      goto 8888
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+8888    continue
+      DO ij=1,iip1
+         dyq(ij,l)=0.
+         dyq(ip1jm+ij,l)=0.
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     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)=q(ij+iip1,l)+dyq(ij+iip1,l)*
+     ,                   0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))
+          ELSE
+              qbyv(ij,l)=q(ij,l)-dyq(ij,l)*
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l))
+          ENDIF
+          qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+c        convpn=SSUM(iim,qbyv(1,l),1)/apoln
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+
+         convpn=SSUM(iim,qbyv(1,l),1)
+         convmpn=ssum(iim,masse_adv_v(1,l),1)
+         massepn=ssum(iim,masse(1,l),1)
+         qpn=0.
+         do ij=1,iim
+            qpn=qpn+masse(ij,l)*q(ij,l)
+         enddo
+         qpn=(qpn+convpn)/(massepn+convmpn)
+         do ij=1,iip1
+            q(ij,l)=qpn
+         enddo
+
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+
+         convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+         convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+         masseps=ssum(iim, masse(ip1jm+1,l),1)
+         qps=0.
+         do ij = ip1jm+1,ip1jmp1-1
+            qps=qps+masse(ij,l)*q(ij,l)
+         enddo
+         qps=(qps+convps)/(masseps+convmps)
+         do ij=ip1jm+1,ip1jmp1
+            q(ij,l)=qps
+         enddo
+
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlz(q,pente_max,masse,w)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c    q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c     dq 	       sont des arguments de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL wq(ip1jmp1,llm+1),newmasse
+
+      REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax
+      REAL sigw
+
+      LOGICAL testcpu
+      SAVE testcpu
+
+      REAL temps0,temps1,temps2,temps3,temps4,temps5,second
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      REAL      SSUM
+      EXTERNAL  SSUM, convflu
+      EXTERNAL filtreg
+
+      DATA testcpu/.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps0=second(0.)
+      ENDIF
+#endif
+      DO l=2,llm
+         DO ij=1,ip1jmp1
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         ENDDO
+      ENDDO
+
+      DO l=2,llm-1
+         DO ij=1,ip1jmp1
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            ELSE
+                dzq(ij,l)=0.
+            ENDIF
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      ENDDO
+
+#ifdef BIDON
+      IF(testcpu) THEN
+         temps1=temps1+second(0.)-temps0
+      ENDIF
+#endif
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+
+       DO l = 1,llm-1
+         do  ij = 1,ip1jmp1
+          IF(w(ij,l+1).gt.0.) THEN
+             sigw=w(ij,l+1)/masse(ij,l+1)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1))
+          ELSE
+             sigw=w(ij,l+1)/masse(ij,l)
+             wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+          ENDIF
+         ENDDO
+       ENDDO
+
+       DO ij=1,ip1jmp1
+          wq(ij,llm+1)=0.
+          wq(ij,1)=0.
+       ENDDO
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+      ENDDO
+
+
+      RETURN
+      END
+c      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+c
+c#include "dimensions.h"
+c#include "paramet.h"
+
+c      CHARACTER*(*) comment
+c      real qmin,qmax
+c      real zq(ip1jmp1,llm)
+
+c      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+
+c      DO k = 1, llm
+c         jbad = 0
+c         DO i = 1, ip1jmp1
+c         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+c            jbad = jbad + 1
+c            jadrs(jbad) = i
+c         ENDIF
+c         ENDDO
+c         IF (jbad.GT.0) THEN
+c         PRINT*, comment
+c         DO i = 1, jbad
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+c         ENDDO
+c         ENDIF
+c      ENDDO
+
+c      return
+c      end
+      subroutine minmaxq(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      character*20 comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+      real zzq(iip1,jjp1,llm)
+
+      integer imin,jmin,lmin,ijlmin
+      integer imax,jmax,lmax,ijlmax
+
+      integer ismin,ismax
+
+      call scopy (ip1jmp1*llm,zq,1,zzq,1)
+
+      ijlmin=ismin(ijp1llm,zq,1)
+      lmin=(ijlmin-1)/ip1jmp1+1
+      ijlmin=ijlmin-(lmin-1.)*ip1jmp1
+      jmin=(ijlmin-1)/iip1+1
+      imin=ijlmin-(jmin-1.)*iip1
+      zqmin=zq(ijlmin,lmin)
+
+      ijlmax=ismax(ijp1llm,zq,1)
+      lmax=(ijlmax-1)/ip1jmp1+1
+      ijlmax=ijlmax-(lmax-1.)*ip1jmp1
+      jmax=(ijlmax-1)/iip1+1
+      imax=ijlmax-(jmax-1.)*iip1
+      zqmax=zq(ijlmax,lmax)
+
+       if(zqmin.lt.qmin) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin)
+       if(zqmax.gt.qmax) 
+c     s     write(*,9999) comment,
+     s     write(*,*) comment,
+     s     imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax)
+
+      return
+9999  format(a20,'  q(',i3,',',i2,',',i2,')=',e12.5,e12.5)
+      end
+
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlspltqs.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlspltqs.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/vlspltqs.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/dyn3d/wrgrads.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/wrgrads.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/wrgrads.F	(revision 428)
@@ -0,0 +1,125 @@
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+c   Declarations
+c    if indice du fichier
+c    nl nombre de couches
+c    field   champ
+c    name    petit nom
+c    titlevar   Titre
+
+#include "gradsdef.h"
+
+c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+      character*10 name,file
+      character*10 titlevar
+
+c   local
+
+      integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+c      print*,'im,jm,lm,name,firsttime(if)'
+c      print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar))
+            nld(ivar(if),if)=nl
+            print*,'initialisation ecriture de ',var(ivar(if),if)
+            print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      do l=1,nl
+         irec(if)=irec(if)+1
+c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))
+     s   ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
+     s   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=file(1:lnblnk(file))//'.ctl',
+     &         form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')
+     &       'DSET ','^'//file(1:lnblnk(file))//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')
+     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
+     &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/writeav.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/writeav.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/dyn3d/writeav.F	(revision 428)
@@ -0,0 +1,433 @@
+      SUBROUTINE writeav(fichnom,nq,pdtav,ptime,pu,pv,
+     .                   pteta,ppk,pq,pps,ifin)
+
+      IMPLICIT NONE
+
+c      Auteur :  L.Fairhead
+
+c      Modif. par P. Le Van ( 01/11/97 )
+
+c=======================================================================
+c
+c   Ecriture des moyennes diurnes  sur le fichier ' histmoy ' , avec
+
+c   la grille ' dynamique ' , c.a.d  decalee , u et v n'etant pas aux
+c   memes endroits que les scalaires .
+c   On ecrit la moyenne tous les jours
+c   si ifin NE 0  on ecrit la moyenne et on ferme le fichier histoire
+c
+c=======================================================================
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comav.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+#include "description.h"
+#include "netcdf.inc"
+
+c   arguments:
+c   ----------
+
+      CHARACTER*(*) fichnom
+      INTEGER nq
+      REAL pdtav
+      REAL pu(ip1jmp1*llm),pv(ip1jm*llm),pteta(ip1jmp1*llm)
+      REAL ppk(ip1jmp1*llm),pq(ip1jmp1*llm,nq)
+      REAL pps(ip1jmp1)
+      REAL ztime,ptime
+
+c   local:
+c   ------
+
+      INTEGER idaym,idayp,i,ifin,iq
+      REAL zdtm,zdtp,dttot
+      REAL zw,zwtot,zz
+      REAL ztimem,ztimep,zdtime
+      REAL um(ip1jmp1*llm),vm(ip1jm*llm),hm(ip1jmp1*llm)
+      REAL qm(ip1jmp1*llm,nqmx)
+      REAL pm(ip1jmp1)
+
+      LOGICAL firstcal
+
+      SAVE idaym
+      SAVE um,vm,hm,qm,pm,dttot
+      SAVE firstcal
+      DATA firstcal/.true./
+      INTEGER ierr, nid, nvarid
+      REAL time
+      CHARACTER*3 str3
+c
+      INTEGER nb
+      SAVE nb
+      DATA nb / 0 /
+
+c-----------------------------------------------------------------------
+c   calcul de la position par rapport aux jours pleins:
+c   ---------------------------------------------------
+
+      IF(firstcal) THEN
+         zz=-time0_av/period_av
+         idaym=INT(zz)
+         IF(zz.LT.0.) idaym=idaym-1
+         dttot=0.
+         CALL initial0(ijp1llm,um)
+         CALL initial0(ijmllm,vm)
+         CALL initial0(ijp1llm,hm)
+         IF(nq.GT.0) CALL initial0(ijp1llm*nq,qm)
+         CALL initial0(ip1jmp1,pm)
+         IF(nq.GT.nqmx) THEN
+            PRINT*,'Il faut augmenter nqmx dans writeav.f'
+            STOP ' writeav '
+         ENDIF
+      ENDIF
+
+      ztime=ptime-time0_av
+      zdtime=pdtav
+      IF(firstcal) THEN
+         ztimem = 0.
+      ELSE
+         ztimem=ztime-.5*pdtav
+      ENDIF
+      firstcal=.false.
+
+      IF(ifin.EQ.0) THEN
+         ztimep=ztime+.5*pdtav
+      ELSE
+         ztimep=ztime
+      ENDIF
+
+      zdtime = ztimep-ztimem
+      zz=ztimep/period_av
+      idayp=INT(zz)
+      IF(zz.LT.0.) idayp=idayp-1
+
+C     PRINT*,period_av,ptime,ztime,idaym,idayp
+
+c-----------------------------------------------------------------------
+c   premier cas: on ne change pas de jour:
+c   --------------------------------------
+
+c    .......   hm  calcule  les temperatures  naturelles  .......
+
+      IF(idaym.EQ.idayp) THEN
+
+         DO i=1,ijp1llm
+            um(i)=um(i)+pu(i)
+            hm(i)=hm(i)+pteta(i) * ppk(i)/cpp
+         ENDDO
+         IF(nq.GT.0) THEN
+            DO iq=1,nq
+               DO i=1,ijp1llm
+                  qm(i,iq)=qm(i,iq)+pq(i,iq)
+               ENDDO
+            ENDDO
+         ENDIF
+         DO i=1,ijmllm
+            vm(i)=vm(i)+pv(i)
+         ENDDO
+         DO i=1,ip1jmp1
+            pm(i)=pm(i)+pps(i)
+         ENDDO
+         dttot=dttot + (ztimep - ztimem)
+
+c-----------------------------------------------------------------------
+c   deuxieme cas: on change de jour dans dtav:
+c   ------------------------------------------
+
+      ELSE
+
+         zdtp=ztimep-FLOAT(idayp)*period_av
+         zdtm=zdtime-zdtp
+
+c   ajout partiel sur le jour precedent:
+c   ------------------------------------
+
+         dttot=dttot+zdtm
+
+         IF(dttot.GT.period_av*1.e-5) THEN
+            zwtot=pdtav/dttot
+            zw=zdtm/pdtav
+
+            DO i=1,ijp1llm
+               um(i)=(um(i)+pu(i)*zw)*zwtot
+               hm(i)=(hm(i)+pteta(i)*ppk(i)/cpp*zw)*zwtot
+            ENDDO
+
+
+            IF (nq.GT.0) THEN
+               DO iq=1,nq
+                  DO i=1,ijp1llm
+                     qm(i,iq)=(qm(i,iq)+pq(i,iq)*zw)*zwtot
+                  ENDDO
+               ENDDO
+            ENDIF
+            DO i=1,ijmllm
+               vm(i)=(vm(i)+pv(i)*zw)*zwtot
+            ENDDO
+            DO i=1,ip1jmp1
+               pm(i)=(pm(i)+pps(i)*zw)*zwtot
+            ENDDO
+
+c   ecriture du fichier de moyenne:
+c   -------------------------------
+
+c   transformation en variables naturelles:
+c   ---------------------------------------
+            CALL covnat(llm,um,vm,um,vm)
+c
+c Ouverture du fichier:
+c
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+c
+c  Ecriture/extension de la coordonnee temps
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable temps n est pas definie"
+         CALL abort
+      ENDIF
+      time = FLOAT(idayp)*period_av-.5*dttot
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time, fichnom
+
+C  Ecriture des champs
+      ierr = NF_INQ_VARID(nid, "temp", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable temp n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,hm)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,hm)
+#endif
+
+c
+      ierr = NF_INQ_VARID(nid, "vitu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable vitu n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,um)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,um)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vitv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable vitv n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vm)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vm)
+#endif
+c
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF ( iq.GT.99 ) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ELSE
+         str3(1:1)='q'
+         WRITE(str3(2:3),'(i2.2)') iq
+         ierr = NF_INQ_VARID(nid, str3, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "writeav: Variable "//str3//" n est pas definie"
+            CALL abort
+         ENDIF
+      ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qm(1,iq))
+#else
+         ierr = NF_PUT_VAR_REAL (nid,nvarid,qm(1,iq))
+#endif
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+
+         ENDIF
+
+c   ajout partiel sur le jour suivant:
+c   ----------------------------------
+
+         dttot=zdtp
+c        PRINT*,'dttot=zdtp',dttot
+         zw=zdtp/pdtav
+
+         DO i=1,ijp1llm
+            um(i)=pu(i)*zw
+            hm(i)=pteta(i)*ppk(i)/cpp*zw
+         ENDDO
+         IF (nq.GT.0) THEN
+            DO iq=1,nq
+               DO i=1,ijp1llm
+                  qm(i,iq)=qm(i,iq)*zw
+               ENDDO
+            ENDDO
+         ENDIF
+         DO i=1,ijmllm
+            vm(i)=pv(i)*zw
+         ENDDO
+         DO i=1,ip1jmp1
+            pm(i)=pps(i)*zw
+         ENDDO
+
+      ENDIF
+
+      idaym=idayp
+
+
+c-----------------------------------------------------------------------
+c   ecriture en fin de run et fermeture du fichier:
+c   -----------------------------------------------
+
+      IF(ifin.NE.0) THEN
+c si un temps non negligeable s'est ecoule depuis la derniere ecriture
+c on sauve garde le champs supplementaire
+
+         IF(dttot.GT.1.e-5*period_av) THEN
+
+            zwtot=pdtav/dttot
+            DO i=1,ijp1llm
+               um(i)=um(i)*zwtot
+               hm(i)=hm(i)*zwtot
+            ENDDO
+
+            DO i=1,ijmllm
+               vm(i)=vm(i)*zwtot
+            ENDDO
+            DO i=1,ip1jmp1
+               pm(i)=pm(i)*zwtot
+            ENDDO
+
+            CALL covnat(llm,um,vm,um,vm)
+
+c
+c Ouverture du fichier:
+c
+      ierr = NF_OPEN(fichnom, NF_WRITE, nid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Pb. d ouverture "//fichnom
+         CALL abort
+      ENDIF
+           
+c  Ecriture/extension de la coordonnee temps
+      nb = nb + 1
+      ierr = NF_INQ_VARID(nid, "temps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable temps n est pas definie"
+         CALL abort
+      ENDIF
+      time = FLOAT(idayp)*period_av-.5*dttot
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time)
+#else
+      ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time)
+#endif
+      PRINT*, "Enregistrement pour ", nb, time, fichnom
+
+C  Ecriture des champs
+      ierr = NF_INQ_VARID(nid, "temp", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable temp n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,hm)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,hm)
+#endif
+
+c
+      ierr = NF_INQ_VARID(nid, "vitu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable vitu n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,um)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,um)
+#endif
+
+      ierr = NF_INQ_VARID(nid, "vitv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable vitv n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vm)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,vm)
+#endif
+c
+      IF(nq.GE.1) THEN
+      DO iq=1,nq
+      IF ( iq.GT.99 ) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ELSE
+         str3(1:1)='q'
+         WRITE(str3(2:3),'(i2.2)') iq
+         ierr = NF_INQ_VARID(nid, str3, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "writeav: Variable "//str3//" n est pas definie"
+            CALL abort
+         ENDIF
+      ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qm(1,iq))
+#else
+         ierr = NF_PUT_VAR_REAL (nid,nvarid,qm(1,iq))
+#endif
+      ENDDO
+      ENDIF
+c
+      ierr = NF_INQ_VARID(nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "writeav: Variable ps n est pas definie"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pps)
+#endif
+
+      ierr = NF_CLOSE(nid)
+c
+
+         ENDIF
+         RETURN
+      ENDIF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/acc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/acc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/acc.F	(revision 428)
@@ -0,0 +1,11 @@
+        subroutine acc(vec,d,im)
+        dimension vec(im,im),d(im)
+        do 10 j=1,im
+        do 9 i=1,im
+ 9	d(i)=vec(i,j)*vec(i,j)
+        sum=ssum(im,d,1)
+        sum=sqrt(sum)
+        do 10 i=1,im
+ 10	vec(i,j)=vec(i,j)/sum
+        return
+        end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/coefils.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/coefils.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/coefils.h	(revision 428)
@@ -0,0 +1,8 @@
+      COMMON/coefils/jfiltnu,jfiltsu,jfiltnv,jfiltsv,sddu(iim),sddv(iim)
+     * ,unsddu(iim),unsddv(iim),coefilu(iim,jjm),coefilv(iim,jjm),
+     * modfrstu(jjm),modfrstv(jjm),eignfnu(iim,iim),eignfnv(iim,iim)
+     * ,coefilu2(iim,jjm),coefilv2(iim,jjm)
+c
+      INTEGER jfiltnu,jfiltsu,jfiltnv,jfiltsv,modfrstu,modfrstv
+      REAL    sddu,sddv,unsddu,unsddv,coefilu,coefilv,eignfnu,eignfnv
+      REAL    coefilu2,coefilv2
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen.F	(revision 428)
@@ -0,0 +1,28 @@
+      SUBROUTINE eigen( e,d)
+#include "dimensions.h"
+      dimension e( iim,iim ), d( iim )
+      dimension asm( iim )
+      im=iim
+c
+      DO 48 i = 1,im
+	 asm( i ) = d( im-i+1 )
+ 48   CONTINUE
+      DO 49 i = 1,iim
+	 d( i ) = asm( i )
+ 49   CONTINUE
+c
+c     PRINT 70,d
+ 70   FORMAT(5x,'Valeurs propres',/,8(1x,8f10.4,/),/)
+		print *
+c
+      DO 51 i = 1,im
+	 DO 52 j = 1,im
+            asm( j ) = e( i , im-j+1 )
+ 52      CONTINUE
+	 DO 50 j = 1,im
+	    e( i,j ) = asm( j )
+ 50      CONTINUE
+ 51   CONTINUE
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen_sort.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen_sort.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/eigen_sort.F	(revision 428)
@@ -0,0 +1,29 @@
+          SUBROUTINE eigen_sort(d,v,n,np)
+          INTEGER n,np
+          REAL d(np),v(np,np)
+          INTEGER i,j,k
+          REAL p
+
+       DO i=1,n-1
+          k=i
+          p=d(i)
+        DO j=i+1,n
+           IF(d(j).ge.p) THEN
+            k=j
+            p=d(j)
+           ENDIF
+        ENDDO
+          
+        IF(k.ne.i) THEN
+          d(k)=d(i)
+          d(i)=p
+         DO j=1,n
+          p=v(j,i)
+          v(j,i)=v(j,k)
+          v(j,k)=p
+         ENDDO
+        ENDIF
+       ENDDO
+
+        RETURN
+        END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/filtreg.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/filtreg.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/filtreg.F	(revision 428)
@@ -0,0 +1,297 @@
+      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
+     .   griscal ,iter)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      nblat                 nombre de latitudes a filtrer
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+#include "coefils.h"
+c
+      INTEGER nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+      REAL  champ( iip1,nlat,nbniv)
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+      REAL  eignq(iim), sdd1(iim),sdd2(iim)
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+c
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     *    STOP'Pas de transformee simple dans cette version'
+
+      IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'
+     * , ' Utiliser old_filtreg et repasser !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ',
+     * ' sur la grille des scalaires !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     *,' corriger et repasser !'
+           STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+             PRINT  1111
+             STOP
+         ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 2
+             jffil1 = jfiltnu
+             jdfil2 = jfiltsu
+             jffil2 = jjm
+          END IF
+      ELSE
+          IF( nlat.NE.jjm )  THEN
+             PRINT  2222
+             STOP
+          ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 1
+             jffil1 = jfiltnv
+             jdfil2 = jfiltsv
+             jffil2 = jjm
+          END IF
+      END IF
+c
+c
+      DO 100  hemisph = 1, 2
+c
+      IF ( hemisph.EQ.1 )  THEN
+          jdfil = jdfil1
+          jffil = jffil1
+      ELSE
+          jdfil = jdfil2
+          jffil = jffil2
+      END IF
+
+ 
+      DO 50  l = 1, nbniv
+      DO 30  j = jdfil,jffil
+ 
+ 
+      DO  5  i = 1, iim
+      champ(i,j,l) = champ(i,j,l) * sdd1(i)
+   5  CONTINUE
+c
+
+      IF( hemisph. EQ. 1 )      THEN
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvn(1,1,j), 1, iim, champ(1,j,l), 1, eignq  , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO k = 1, iim
+      DO i = 1, iim
+         eignq(k) = eignq(k) + matrinvn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceun(1,1,j), 1, iim, champ(1,j,l), 1, eignq ,
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceun(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceun(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ELSE
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvs(1,1,j-jfiltsu+1),  1, iim, champ(1,j,l),1 ,  
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvs(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matrinvs(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceus(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceus(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceus(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevs(1,1,j-jfiltsv+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevs(1,1,j-jfiltsv+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevs(k,i,j-jfiltsv+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ENDIF
+c
+      IF( ifiltre.EQ. 2 )  THEN
+        DO 15 i = 1, iim
+        champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i)
+  15    CONTINUE
+      ELSE
+        DO 16 i=1,iim
+        champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i)
+16      CONTINUE
+      ENDIF
+c
+      champ( iip1,j,l ) = champ( 1,j,l )
+c
+  30  CONTINUE
+c
+  50  CONTINUE
+c    
+ 100  CONTINUE
+c
+1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     *filtrer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     *ltrer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifgn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifgn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifgn.F	(revision 428)
@@ -0,0 +1,103 @@
+      SUBROUTINE inifgn(dv)
+c  
+c    ...  H.Upadyaya , O.Sharma  ... 
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "serre.h"
+
+c
+      REAL vec(iim,iim),vec1(iim,iim)
+      REAL dlonu(iim),dlonv(iim)
+      REAL du(iim),dv(iim),d(iim)
+      REAL pi
+      INTEGER i,j,k,imm1,nrot
+C
+#include "coefils.h"
+c
+      EXTERNAL SSUM, acc,eigen,jacobi
+      REAL SSUM
+c
+
+      imm1  = iim -1
+      pi = 2.* ASIN(1.)
+C
+      DO 5 i=1,iim
+       dlonu(i)=  xprimu( i )
+       dlonv(i)=  xprimv( i )
+   5  CONTINUE
+
+      DO 12 i=1,iim
+      sddv(i)   = SQRT(dlonv(i))
+      sddu(i)   = SQRT(dlonu(i))
+      unsddu(i) = 1./sddu(i)
+      unsddv(i) = 1./sddv(i)
+  12  CONTINUE
+C
+      DO 17 j=1,iim
+      DO 17 i=1,iim
+      vec(i,j)     = 0.
+      vec1(i,j)    = 0.
+      eignfnv(i,j) = 0.
+      eignfnu(i,j) = 0.
+  17  CONTINUE
+c
+c
+      eignfnv(1,1)    = -1.
+      eignfnv(iim,1)  =  1.
+      DO 20 i=1,imm1
+      eignfnv(i+1,i+1)= -1.
+      eignfnv(i,i+1)  =  1.
+  20  CONTINUE
+      DO 25 j=1,iim
+      DO 25 i=1,iim
+      eignfnv(i,j) = eignfnv(i,j)/(sddu(i)*sddv(j))
+  25  CONTINUE
+      DO 30 j=1,iim
+      DO 30 i=1,iim
+      eignfnu(i,j) = -eignfnv(j,i)
+  30  CONTINUE
+c
+#ifdef CRAY
+      CALL MXM(eignfnu,iim,eignfnv,iim,vec ,iim)
+      CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+#else
+      DO j = 1, iim
+      DO i = 1, iim
+        vec (i,j) = 0.0
+        vec1(i,j) = 0.0
+       DO k = 1, iim
+        vec (i,j) = vec(i,j)  + eignfnu(i,k) * eignfnv(k,j)
+        vec1(i,j) = vec1(i,j) + eignfnv(i,k) * eignfnu(k,j)
+       ENDDO
+      ENDDO
+      ENDDO
+#endif
+
+c
+      CALL jacobi(vec,iim,iim,dv,eignfnv,nrot)
+      CALL acc(eignfnv,d,iim)
+      CALL eigen_sort(dv,eignfnv,iim,iim)
+c
+      CALL jacobi(vec1,iim,iim,du,eignfnu,nrot)
+      CALL acc(eignfnu,d,iim)
+      CALL eigen_sort(du,eignfnu,iim,iim)
+
+cc   ancienne version avec appels IMSL
+c
+c     CALL MXM(eignfnu,iim,eignfnv,iim,vec,iim)
+c     CALL MXM(eignfnv,iim,eignfnu,iim,vec1,iim)
+c     CALL EVCSF(iim,vec,iim,dv,eignfnv,iim)
+c     CALL acc(eignfnv,d,iim)
+c     CALL eigen(eignfnv,dv)
+c
+c     CALL EVCSF(iim,vec1,iim,du,eignfnu,iim)
+c     CALL acc(eignfnu,d,iim)
+c     CALL eigen(eignfnu,du)
+
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifilr.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifilr.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/inifilr.F	(revision 428)
@@ -0,0 +1,584 @@
+      SUBROUTINE inifilr
+c
+c    ... H. Upadhyaya, O.Sharma   ...
+c
+      IMPLICIT NONE
+c
+c     version 3 .....
+
+c     Correction  le 28/10/97    P. Le Van .
+c  -------------------------------------------------------------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+c  -------------------------------------------------------------------
+#include "comgeom.h"
+#include "coefils.h"
+#include "logic.h"
+#include "serre.h"
+
+      REAL  dlonu(iim),dlatu(jjm)
+      REAL  rlamda( iim ),  eignvl( iim )
+c
+
+      REAL    lamdamax,pi,cof
+      INTEGER i,j,modemax,imx,k,kf,ii
+      REAL dymin,dxmin,colat0
+      REAL eignft(iim,iim), coff
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+#ifdef CRAY
+      INTEGER   ISMIN
+      EXTERNAL  ISMIN
+      INTEGER iymin 
+      INTEGER ixmineq
+#endif
+      EXTERNAL  inifgn
+c
+c ------------------------------------------------------------
+c   This routine computes the eigenfunctions of the laplacien
+c   on the stretched grid, and the filtering coefficients
+c      
+c  We designate:
+c   eignfn   eigenfunctions of the discrete laplacien
+c   eigenvl  eigenvalues
+c   jfiltn   indexof the last scalar line filtered in NH
+c   jfilts   index of the first line filtered in SH
+c   modfrst  index of the mode from where modes are filtered
+c   modemax  maximum number of modes ( im )
+c   coefil   filtering coefficients ( lamda_max*cos(rlat)/lamda )
+c   sdd      SQRT( dx )
+c      
+c     the modes are filtered from modfrst to modemax
+c      
+c-----------------------------------------------------------
+c
+
+       pi       = 2. * ASIN( 1. )
+
+       DO i = 1,iim
+        dlonu(i) = xprimu( i )
+       ENDDO
+c
+       CALL inifgn(eignvl)
+c
+        print *,' EIGNVL '
+        PRINT 250,eignvl
+250     FORMAT( 1x,5e13.6)
+c
+c compute eigenvalues and eigenfunctions
+c
+c
+c.................................................................
+c
+c  compute the filtering coefficients for scalar lines and 
+c  meridional wind v-lines
+c
+c  we filter all those latitude lines where coefil < 1
+c  NO FILTERING AT POLES
+c
+c  colat0 is to be used  when alpha (stretching coefficient)
+c  is set equal to zero for the regular grid case 
+c
+c    .......   Calcul  de  colat0   .........
+c     .....  colat0 = minimum de ( 0.5, min dy/ min dx )   ...
+c
+c
+      DO 45 j = 1,jjm
+         dlatu( j ) = rlatu( j ) - rlatu( j+1 )
+ 45   CONTINUE
+c
+#ifdef CRAY
+      iymin   = ISMIN( jjm, dlatu, 1 )
+      ixmineq = ISMIN( iim, dlonu, 1 )
+      dymin   = dlatu( iymin )
+      dxmin   = dlonu( ixmineq )
+#else
+      dxmin   =  dlonu(1)
+       DO  i  = 2, iim
+        dxmin = MIN( dxmin,dlonu(i) )
+       ENDDO
+      dymin  = dlatu(1)
+       DO j  = 2, jjm
+        dymin = MIN( dymin,dlatu(j) )
+       ENDDO
+#endif
+c
+c
+      colat0  =  MIN( 0.5, dymin/dxmin )
+c
+      IF( .NOT.fxyhypb.AND.ysinus )  THEN
+           colat0 = 0.6
+c         ...... a revoir  pour  ysinus !   .......
+           alphax = 0.
+      ENDIF
+c
+      PRINT 50, colat0,alphax
+  50  FORMAT(/15x,' Inifilr colat0 alphax ',2e16.7)
+c
+      IF(alphax.EQ.1. )  THEN
+        PRINT *,' Inifilr  alphax doit etre  <  a 1.  Corriger '
+         STOP
+      ENDIF
+c
+      lamdamax = iim / ( pi * colat0 * ( 1. - alphax ) )
+
+cc                        ... Correction  le 28/10/97  ( P.Le Van ) ..
+c
+      DO 71 i = 2,iim
+       rlamda( i ) = lamdamax/ SQRT( ABS( eignvl(i) ) )
+ 71   CONTINUE
+c
+
+      DO 72 j = 1,jjm
+	    DO 73 i = 1,iim
+	    coefilu( i,j )  = 0.0
+	    coefilv( i,j )  = 0.0
+	    coefilu2( i,j ) = 0.0
+	    coefilv2( i,j ) = 0.0
+ 73     CONTINUE
+ 72   CONTINUE
+
+c
+c    ... Determination de jfiltnu,jfiltnv,jfiltsu,jfiltsv ....
+c    .........................................................
+c
+       modemax = iim
+
+cccc    imx = modemax - 4 * (modemax/iim)
+
+       imx  = iim
+c
+       PRINT *,' TRUNCATION AT ',imx
+c
+      DO 75 j = 2, jjm/2+1
+       cof = COS( rlatu(j) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(j) ).LT.1. ) jfiltnu= j
+        ENDIF
+
+       cof = COS( rlatu(jjp1-j+1) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatu(jjp1-j+1) ).LT.1. )
+     $      jfiltsu= jjp1-j+1
+        ENDIF
+ 75   CONTINUE
+c
+      DO 76 j = 1, jjm/2
+       cof = COS( rlatv(j) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(j) ).LT.1. ) jfiltnv= j
+        ENDIF
+
+       cof = COS( rlatv(jjm-j+1) )/ colat0
+	    IF ( cof .LT. 1. ) THEN
+          IF( rlamda(imx) * COS(rlatv(jjm-j+1) ).LT.1. )
+     $       jfiltsv= jjm-j+1
+        ENDIF
+ 76   CONTINUE
+c                                 
+
+      IF( jfiltnu.LE.0 .OR. jfiltnu.GT. jjm/2 +1 )  THEN
+        PRINT *,' jfiltnu en dehors des valeurs acceptables ' ,jfiltnu
+        STOP
+      ENDIF
+
+      IF( jfiltsu.LE.0 .OR. jfiltsu.GT.  jjm  +1 )  THEN
+        PRINT *,' jfiltsu en dehors des valeurs acceptables ' ,jfiltsu
+        STOP
+      ENDIF
+
+      IF( jfiltnv.LE.0 .OR. jfiltnv.GT. jjm/2    )  THEN
+        PRINT *,' jfiltnv en dehors des valeurs acceptables ' ,jfiltnv
+        STOP
+      ENDIF
+
+      IF( jfiltsv.LE.0 .OR. jfiltsv.GT.     jjm  )  THEN
+        PRINT *,' jfiltsv en dehors des valeurs acceptables ' ,jfiltsv
+        STOP
+      ENDIF
+
+       PRINT *,' jfiltnv jfiltsv jfiltnu jfiltsu ' ,
+     *           jfiltnv,jfiltsv,jfiltnu,jfiltsu
+
+c                                 
+c   ... Determination de coefilu,coefilv,n=modfrstu,modfrstv ....
+c................................................................
+c
+c
+      DO 77 j = 1,jjm
+	  modfrstu( j ) = iim
+	  modfrstv( j ) = iim
+ 77   CONTINUE
+c
+      DO 84 j = 2,jfiltnu
+       DO 81 k = 2,modemax
+	     cof = rlamda(k) * COS( rlatu(j) )
+         IF ( cof .LT. 1. ) GOTO 82
+ 81    CONTINUE
+      GOTO 84
+ 82   modfrstu( j ) = k
+c
+	  kf = modfrstu( j )
+	   DO 83 k = kf , modemax
+        cof = rlamda(k) * COS( rlatu(j) )
+	    coefilu(k,j) = cof - 1.
+	    coefilu2(k,j) = cof*cof - 1.
+ 83    CONTINUE
+ 84   CONTINUE
+c                                 
+c
+      DO 89 j = 1,jfiltnv
+c
+       DO 86 k = 2,modemax
+	    cof = rlamda(k) * COS( rlatv(j) )
+         IF ( cof .LT. 1. ) GOTO 87
+ 86    CONTINUE
+      GOTO 89
+ 87   modfrstv( j ) = k
+c
+	   kf = modfrstv( j )
+	   DO 88 k = kf , modemax
+        cof = rlamda(k) * COS( rlatv(j) )
+	    coefilv(k,j) = cof - 1.
+	    coefilv2(k,j) = cof*cof - 1.
+ 88    CONTINUE
+c
+ 89    CONTINUE
+c
+      DO 94 j = jfiltsu,jjm
+       DO 91 k = 2,modemax
+	    cof = rlamda(k) * COS( rlatu(j) )
+         IF ( cof .LT. 1. ) GOTO 92
+ 91    CONTINUE
+      GOTO 94
+ 92   modfrstu( j ) = k
+c
+        kf = modfrstu( j )
+	 DO 93 k = kf , modemax
+          cof = rlamda(k) * COS( rlatu(j) )
+	  coefilu(k,j) = cof - 1.
+	  coefilu2(k,j) = cof*cof - 1.
+ 93      CONTINUE
+ 94    CONTINUE
+c                                 
+      DO 99 j = jfiltsv,jjm
+       DO 96 k = 2,modemax
+	     cof = rlamda(k) * COS( rlatv(j) )
+         IF ( cof .LT. 1. ) GOTO 97
+ 96    CONTINUE
+      GOTO 99
+ 97   modfrstv( j ) = k
+c
+       kf = modfrstv( j )
+	   DO 98 k = kf , modemax
+        cof = rlamda(k) * COS( rlatv(j) )
+	    coefilv(k,j) = cof - 1.
+	    coefilv2(k,j) = cof*cof - 1.
+ 98    CONTINUE
+ 99   CONTINUE
+c
+
+       IF(jfiltnv.GE.jjm/2 .OR. jfiltnu.GE.jjm/2)THEN
+
+         IF(jfiltnv.EQ.jfiltsv)jfiltsv=1+jfiltnv
+         IF(jfiltnu.EQ.jfiltsu)jfiltsu=1+jfiltnu
+
+          PRINT *,'jfiltnv jfiltsv jfiltnu jfiltsu' ,
+     *        jfiltnv,jfiltsv,jfiltnu,jfiltsu
+       ENDIF
+
+       PRINT *,'   Modes premiers  v  '
+       PRINT 334,modfrstv
+       PRINT *,'   Modes premiers  u  '
+       PRINT 334,modfrstu
+
+     
+      IF( nfilun.LT. jfiltnu )  THEN
+       PRINT *,' le parametre nfilun utilise pour la matrice ',
+     *   ' matriceun  est trop petit ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnu
+        PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilun.GT. jfiltnu+ 2 )  THEN
+           PRINT *,' le parametre nfilun utilise pour la matrice ',
+     *' matriceun est trop grand ! Gachis de memoire ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnu
+        PRINT *,' Pour information, nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilus.LT. jjm - jfiltsu +1 )  THEN
+            PRINT *,' le parametre nfilus utilise pour la matrice ',
+     *   ' matriceus  est trop petit !  '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  ',
+     * jjm - jfiltsu + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilus.GT. jjm - jfiltsu + 3 )  THEN
+           PRINT *,' le parametre nfilus utilise pour la matrice ',
+     * ' matriceus  est trop grand ! ' 
+       PRINT *,' Le changer dans parafilt.h et le mettre a  ' ,
+     * jjm - jfiltsu + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilvn.LT. jfiltnv )  THEN
+            PRINT *,' le parametre nfilvn utilise pour la matrice ',
+     *   ' matricevn  est trop petit ! '  
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnv
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilvn.GT. jfiltnv+ 2 )  THEN
+           PRINT *,' le parametre nfilvn utilise pour la matrice ',
+     *' matricevn est trop grand !  Gachis de memoire ! ' 
+       PRINT *,'Le changer dans parafilt.h et le mettre a  ',jfiltnv
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+      IF( nfilvs.LT. jjm - jfiltsv +1 )  THEN
+            PRINT *,' le parametre nfilvs utilise pour la matrice ',
+     *   ' matricevs  est trop petit !  Le changer dans parafilt.h '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  '
+     * , jjm - jfiltsv + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+               STOP
+      ENDIF
+      IF( nfilvs.GT. jjm - jfiltsv + 3 )  THEN
+           PRINT *,' le parametre nfilvs utilise pour la matrice ',
+     * ' matricevs  est trop grand ! Gachis de memoire ! '
+       PRINT *,' Le changer dans parafilt.h et le mettre a  '
+     *   ,  jjm - jfiltsv + 1
+        PRINT *,' Pour information , nfilun,nfilus,nfilvn,nfilvs '
+     * ,'doivent etre egaux successivement a  ',jfiltnu,jjm-jfiltsu+1
+     *  ,jfiltnv,jjm-jfiltsv+1
+c              STOP
+      ENDIF
+
+c  
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matriceu'  pour les champs situes
+c                       sur la grille scalaire                 ........
+c   ...................................................................
+c
+        DO j = 2, jfiltnu
+
+         DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+           DO k=1,iim
+            eignft(i,k) = eignfnv(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM( eignfnv,iim,eignft,iim,matriceun(1,1,j),iim )
+#else
+#ifdef BLAS
+         CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $   eignfnv, iim, eignft, iim, 0.0, matriceun(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matriceun(i,k,j) = 0.0
+            DO ii = 1, iim
+               matriceun(i,k,j) = matriceun(i,k,j)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsu, jjm
+
+         DO i=1,iim
+          coff = coefilu(i,j)
+          IF( i.LT.modfrstu(j) ) coff = 0.
+            DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnv,iim,eignft,iim,matriceus(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $           eignfnv, iim, eignft, iim, 0.0, 
+     $           matriceus(1,1,j-jfiltsu+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matriceus(i,k,j-jfiltsu+1) = 0.0
+            DO ii = 1, iim
+               matriceus(i,k,j-jfiltsu+1) = matriceus(i,k,j-jfiltsu+1)
+     .                                    + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matricev'  pour les champs situes
+c                       sur la grille   de V ou de Z           ........
+c   ...................................................................
+c
+        DO j = 1, jfiltnv
+
+         DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+           DO k = 1, iim
+            eignft(i,k) = eignfnu(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+          CALL MXM( eignfnu,iim,eignft,iim,matricevn(1,1,j),iim )
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $     eignfnu, iim, eignft, iim, 0.0, matricevn(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matricevn(i,k,j) = 0.0
+            DO ii = 1, iim
+               matricevn(i,k,j) = matricevn(i,k,j)
+     .                          + eignfnu(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsv, jjm
+
+         DO i = 1, iim
+          coff = coefilv(i,j)
+          IF( i.LT.modfrstv(j) ) coff = 0.
+            DO k = 1, iim
+             eignft(i,k) = eignfnu(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnu,iim,eignft,iim,matricevs(1,1,j-jfiltsv+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $           eignfnu, iim, eignft, iim, 0.0, 
+     $           matricevs(1,1,j-jfiltsv+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matricevs(i,k,j-jfiltsv+1) = 0.0
+            DO ii = 1, iim
+               matricevs(i,k,j-jfiltsv+1) = matricevs(i,k,j-jfiltsv+1)
+     .                          + eignfnu(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+c
+c   ... Calcul de la matrice filtre 'matrinv'  pour les champs situes
+c              sur la grille scalaire , pour le filtre inverse ........
+c   ...................................................................
+c
+        DO j = 2, jfiltnu
+
+         DO i = 1,iim
+          coff = coefilu(i,j)/ ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+           DO k=1,iim
+            eignft(i,k) = eignfnv(k,i) * coff
+           ENDDO
+         ENDDO
+#ifdef CRAY
+          CALL MXM( eignfnv,iim,eignft,iim,matrinvn(1,1,j),iim )
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $     eignfnv, iim, eignft, iim, 0.0, matrinvn(1,1,j), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matrinvn(i,k,j) = 0.0
+            DO ii = 1, iim
+               matrinvn(i,k,j) = matrinvn(i,k,j)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+        DO j = jfiltsu, jjm
+
+         DO i = 1,iim
+          coff = coefilu(i,j) / ( 1. + coefilu(i,j) )
+          IF( i.LT.modfrstu(j) ) coff = 0.
+            DO k=1,iim
+             eignft(i,k) = eignfnv(k,i) * coff
+            ENDDO
+         ENDDO
+#ifdef CRAY
+         CALL MXM(eignfnv,iim,eignft,iim,matrinvs(1,1,j-jfiltsu+1),iim)
+#else
+#ifdef BLAS
+      CALL SGEMM ('N', 'N', iim, iim, iim, 1.0,
+     $ eignfnv, iim, eignft, iim, 0.0, matrinvs(1,1,j-jfiltsu+1), iim)
+#else
+         DO k = 1, iim
+         DO i = 1, iim
+            matrinvs(i,k,j-jfiltsu+1) = 0.0
+            DO ii = 1, iim
+               matrinvs(i,k,j-jfiltsu+1) = matrinvs(i,k,j-jfiltsu+1)
+     .                          + eignfnv(i,ii)*eignft(ii,k)
+            ENDDO
+         ENDDO
+         ENDDO
+#endif
+#endif
+
+        ENDDO
+
+c   ...................................................................
+
+c
+334    FORMAT(1x,24i3)
+755    FORMAT(1x,6f10.3,i3)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/jacobi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/jacobi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/jacobi.F	(revision 428)
@@ -0,0 +1,94 @@
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      PARAMETER (NMAX=400)
+      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
+      IF (n.gt.nmax) THEN
+         print*, 'n, nmax=', n, nmax
+         print*, 'Surdimensionnement insuffisant dans jacobi'
+         CALL abort
+      ENDIF
+      DO 12 IP=1,N
+        DO 11 IQ=1,N
+          V(IP,IQ)=0.
+11      CONTINUE
+        V(IP,IP)=1.
+12    CONTINUE
+      DO 13 IP=1,N
+        B(IP)=A(IP,IP)
+        D(IP)=B(IP)
+        Z(IP)=0.
+13    CONTINUE
+      NROT=0
+      DO 24 I=1,50
+        SM=0.
+        DO 15 IP=1,N-1
+          DO 14 IQ=IP+1,N
+            SM=SM+ABS(A(IP,IQ))
+14        CONTINUE
+15      CONTINUE
+        IF(SM.EQ.0.)RETURN
+        IF(I.LT.4)THEN
+          TRESH=0.2*SM/N**2
+        ELSE
+          TRESH=0.
+        ENDIF
+        DO 22 IP=1,N-1
+          DO 21 IQ=IP+1,N
+            G=100.*ABS(A(IP,IQ))
+            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
+     *         .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
+              A(IP,IQ)=0.
+            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
+              H=D(IQ)-D(IP)
+              IF(ABS(H)+G.EQ.ABS(H))THEN
+                T=A(IP,IQ)/H
+              ELSE
+                THETA=0.5*H/A(IP,IQ)
+                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
+                IF(THETA.LT.0.)T=-T
+              ENDIF
+              C=1./SQRT(1+T**2)
+              S=T*C
+              TAU=S/(1.+C)
+              H=T*A(IP,IQ)
+              Z(IP)=Z(IP)-H
+              Z(IQ)=Z(IQ)+H
+              D(IP)=D(IP)-H
+              D(IQ)=D(IQ)+H
+              A(IP,IQ)=0.
+              DO 16 J=1,IP-1
+                G=A(J,IP)
+                H=A(J,IQ)
+                A(J,IP)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+16            CONTINUE
+              DO 17 J=IP+1,IQ-1
+                G=A(IP,J)
+                H=A(J,IQ)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+17            CONTINUE
+              DO 18 J=IQ+1,N
+                G=A(IP,J)
+                H=A(IQ,J)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(IQ,J)=H+S*(G-H*TAU)
+18            CONTINUE
+              DO 19 J=1,N
+                G=V(J,IP)
+                H=V(J,IQ)
+                V(J,IP)=G-S*(H+G*TAU)
+                V(J,IQ)=H+S*(G-H*TAU)
+19            CONTINUE
+              NROT=NROT+1
+            ENDIF
+21        CONTINUE
+22      CONTINUE
+        DO 23 IP=1,N
+          B(IP)=B(IP)+Z(IP)
+          D(IP)=B(IP)
+          Z(IP)=0.
+23      CONTINUE
+24    CONTINUE
+      STOP '50 iterations should never happen'
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/parafilt.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/parafilt.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/filtrez/parafilt.h	(revision 428)
@@ -0,0 +1,40 @@
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c        PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+c      PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+
+c 96 72 19 non-zoom:
+      PARAMETER (nfilun=12, nfilus=11, nfilvn=12, nfilvs=12)
+c
+c        PARAMETER ( nfilun=20, nfilus=20, nfilvn=20, nfilvs=20 )
+c        PARAMETER ( nfilun=8, nfilus=7, nfilvn=7, nfilvs=7 )
+c
+c
+c      Ici , on a exagere  les nombres de lignes de latitudes a filtrer .
+c
+c      La premiere fois que  le Gcm  rentrera  dans le Filtre ,
+c
+c      il indiquera  les bonnes valeurs  de  nfilun , nflius, nfilvn  et 
+c
+c      nfilvs  a  mettre .  Il suffira alors de changer ces valeurs dans
+c
+c      Parameter  ci-dessus  et de relancer  le  run .  
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t4
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t4	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t4	(revision 428)
@@ -0,0 +1,16 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'dimensions.h'
+c
+c   dimensions.h contient les dimensions du modele
+c   ndm est tel que iim=2**ndm
+c   nqmx est la dimension de la variable traceur q
+c-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= 48,jjm=32,llm=19,ndm=1)
+
+      integer nqmx
+      parameter (nqmx=4)
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t6
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t6	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.48.32.19.t6	(revision 428)
@@ -0,0 +1,16 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'dimensions.h'
+c
+c   dimensions.h contient les dimensions du modele
+c   ndm est tel que iim=2**ndm
+c   nqmx est la dimension de la variable traceur q
+c-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= 48,jjm=32,llm=19,ndm=1)
+
+      integer nqmx
+      parameter (nqmx=6)
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.96.72.19.t4
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.96.72.19.t4	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/dimensions.96.72.19.t4	(revision 428)
@@ -0,0 +1,16 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'dimensions.h'
+c
+c   dimensions.h contient les dimensions du modele
+c   ndm est tel que iim=2**ndm
+c   nqmx est la dimension de la variable traceur q
+c-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= 96,jjm=72,llm=19,ndm=1)
+
+      integer nqmx
+      parameter (nqmx=4)
+
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/makdim
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/makdim	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/dimension/makdim	(revision 428)
@@ -0,0 +1,70 @@
+nqmx=$1
+shift
+for i in $* ; do
+   list=$list.$i
+done
+fichdim=dimensions${list}.t${nqmx}
+
+if [ ! -f $fichdim ] ; then
+# si le fichier de dimensions n'existe pas, on le cree
+
+  if [ $# -ge 3 ] ; then
+     im=$1
+     jm=$2
+     lm=$3
+     n2=$1
+     ndm=1
+
+# Le test suivant est commente car il est inutile avec le nouveau 
+# filtre filtrez. Attention avec le "vieux" filtre (F. Forget,11/1994)
+#
+#     while [ "$n2" -gt 2 ]; do
+#       n2=`expr $n2 / 2`
+#       ndm=`expr $ndm + 1`
+#       echo $n2
+#    done
+#    if [ "$n2" != 2 ] ; then
+#       echo le nombre de longitude doit etre une puissance de 2
+#       exit
+#    fi
+
+
+  else if [ $# -ge 2 ] ; then
+      im=1
+      jm=$1
+      lm=$2
+      ndm=1
+  else if [ $# -ge 1 ] ; then
+      im=1
+      jm=1
+      lm=$1
+      ndm=1
+  else
+         echo il faut au moins une dimension
+         exit
+  fi
+fi
+fi
+
+cat << EOF > $fichdim
+c-----------------------------------------------------------------------
+c   INCLUDE 'dimensions.h'
+c
+c   dimensions.h contient les dimensions du modele
+c   ndm est tel que iim=2**ndm
+c   nqmx est la dimension de la variable traceur q
+c-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm)
+
+      integer nqmx
+      parameter (nqmx=$nqmx)
+
+c-----------------------------------------------------------------------
+EOF
+fi
+
+\rm ../dimensions.h
+tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h )
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_new.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_new.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_new.h	(revision 428)
@@ -0,0 +1,24 @@
+c--------------------------------------------------------------
+         REAL ripx
+         REAL fx,fxprim,fy,fyprim,ri,rj,bigy
+c
+c....stretching in x...
+c
+        ripx(  ri )= (ri-1.0) *2.*pi/FLOAT(iim) 
+        fx  (  ri )= ripx(ri) + transx  +
+     *         alphax * SIN( ripx(ri)+transx-pxo ) - pi
+        fxprim(ri) = 2.*pi/FLOAT(iim)  *
+     *        ( 1.+ alphax * COS( ripx(ri)+transx-pxo ) )
+
+c....stretching in y...
+c
+        bigy(rj)   = 2.* (FLOAT(jjp1)-rj ) *pi/jjm
+        fy(rj)     =  ( bigy(rj) + transy  +
+     *        alphay * SIN( bigy(rj)+transy-pyo ) ) /2.  - pi/2.
+        fyprim(rj) = ( pi/jjm ) * ( 1.+
+     *           alphay * COS( bigy(rj)+transy-pyo ) )
+
+c       fy(rj)= pyo-pisjjm*(rj-transy)+coefalpha*SIN(depisjm*(rj-
+c     *  transy ))
+c       fyprim(rj)= pisjjm-pisjjm*coefy2* COS(depisjm*(rj-transy)) 
+c--------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_reg.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_reg.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_reg.h	(revision 428)
@@ -0,0 +1,42 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/FLOAT(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_sin.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_sin.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxy_sin.h	(revision 428)
@@ -0,0 +1,39 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+      fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxyprim.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxyprim.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/grid/fxyprim.h	(revision 428)
@@ -0,0 +1,42 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'fxyprim.h'
+c
+c    ................................................................
+c    ................  Fonctions in line  ...........................
+c    ................................................................
+c
+      REAL  fy, fx, fxprim, fyprim
+      REAL  ri, rj
+c
+c
+      fy    ( rj ) =    pi/FLOAT(jjm) * ( 0.5 * FLOAT(jjm) +  1. - rj  )
+      fyprim( rj ) =    pi/FLOAT(jjm)
+
+c     fy(rj)=ASIN(1.+2.*((1.-rj)/FLOAT(jjm)))
+c     fyprim(rj)=1./SQRT((rj-1.)*(jjm+1.-rj))
+
+      fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5*  FLOAT(iim) - 1. )
+c     fx    ( ri ) = 2.*pi/FLOAT(iim) * ( ri - 0.5* ( FLOAT(iim) + 1.) )
+      fxprim( ri ) = 2.*pi/FLOAT(iim)
+c
+c
+c    La valeur de pi est passee par le common/const/ou /const2/ .
+c    Sinon, il faut la calculer avant d'appeler ces fonctions .
+c
+c   ----------------------------------------------------------------
+c     Fonctions a changer eventuellement, selon x(x) et y(y) choisis .
+c   -----------------------------------------------------------------
+c
+c    .....  ici, on a l'application particuliere suivante   ........
+c
+c                **************************************
+c                **     x = 2. * pi/iim *  X         **
+c                **     y =      pi/jjm *  Y         **
+c                **************************************
+c
+c   ..................................................................
+c   ..................................................................
+c
+c
+c
+c-----------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.h	(revision 428)
@@ -0,0 +1,36 @@
+C     ------------------------------------------------------------------
+C     This COMDECK includes the Thermodynamical functions for the cy39
+C       ECMWF Physics package.
+C       Consistent with YOMCST Basic physics constants, assuming the
+C       partial pressure of water vapour is given by a first order
+C       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+C       in YOETHF
+C     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+C
+      FOEEW ( PTARG,PDELARG ) = EXP (
+     S          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     S / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+C
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG
+     S / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+c
+      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))
+c
+      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/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/FCTTRE.inc	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/LISEZMOI
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/LISEZMOI	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/LISEZMOI	(revision 428)
@@ -0,0 +1,74 @@
+Cette version de la physique est denommee "phylmd_oct98"
+Cette version a ete construite sur la base de "phylmd_juin96"
+(LMDZ.2.0). L'esprit est de rendre la structure du modele plus
+adaptee pour de futures evolutions tout en gardant, quand c'est
+possible, la version de base. Donc, theoriquement, cette version
+par defaut est tres proche de la version precedente. En resume:
+-- informatique: rupture importante avec "phylmd_juin96"
+-- physique: continuite avec "phylmd_juin96"
+
+De nombreuses clefs sont introduites pour controler les options:
+- check: verifier la conservation du modele en eau
+- ok_ocean: modele oceanique "slab ocean"
+- ok_oasis: couplage OASIS (ocean complet, type OPA du LODYC)
+- cycle_diurne: introduction du cycle diurne
+- soil_model: modele thermique du sol (pour le cycle diurne)
+- new_oliq: une nouvelle eau liquide pour le rayonnement
+- ok_orodr: parametrisation de l'orographie
+- ok_orolf: parametrisation de l'orographie
+- ok_journe: sortir le fichier journalier
+- ok_instan: sortir le fichier instantane
+- ok_region: sortir le fichier regional
+
+La structure du programme est la suivante:
+
+- suphec
+- phyetat0
+- sugwd
+- soil
+- o3cm
+
+- hgardfou
+- condsurf
+- ozonecm
+- clmain
+- soil
+- convection (conlmd, conflx, conccm)
+- homogene
+- flxtr
+- ajsec
+- fisrtilp
+- nuage
+- orbite
+- angle
+- alboc
+- albsno
+- radlwsw 
+- hydrol
+- drag_noro
+- lift_noro
+- transp
+
+- phyredem
+
+Quelques explications supplementaires:
+
+(1) La couche limite est appelee au debut de la physique. Elle
+fonctionne pour des sous-fractions de maille. Diffusion d'un
+traceur passif est maintenant possible
+
+(2) Le rayonnement est une version nouvelle (radlwsw), qui
+correspond a Arpege-IFS (debut 1997). L'option sur le recouvrement
+vertical des nuages est controlee dans radopt.h. Le rayonnement
+peut fonctionner maintenant region par region, ce qui reduit la
+taille en memoire du code (voir raddim.h)
+
+(3) Plusieurs schemas de convection sont au choix. Le schema
+classique du LMD (Manabe+Kuo) a subit des transformations
+importantes. Un nouveau modele est introduit pour traiter la
+condensation pendant la convection.
+
+(4) La condensation a grande echelle et la parametrisation des
+nuages sont traitees dans fisrtilp.F. La transition eau/glace
+est differente. La pluie tombante subit des eveporations si elle
+traverse des zones non-saturees.
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOECUMF.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOECUMF.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOECUMF.h	(revision 428)
@@ -0,0 +1,39 @@
+C     ----------------------------------------------------------------
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C     ----------------------------------------------------------------
+C
+      COMMON /YOECUMF/
+     L                 LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV,
+     R                 ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,
+     R                 CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON
+C
+      LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
+      REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
+      REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
+C
+*if (DOC,declared) <> 'UNKNOWN'
+C*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+C
+C     M.TIEDTKE       E. C. M. W. F.      18/1/89
+C
+C     NAME      TYPE      PURPOSE
+C     ----      ----      -------
+C
+C     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
+C     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
+C     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
+C     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
+C     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
+C     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+C     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
+C     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+C     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+C     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
+C     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
+C     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
+C     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+C     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
+C     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
+C                        FROM CLOUD WATER TO RAIN
+*ifend
+C     ----------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOEGWD.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOEGWD.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOEGWD.h	(revision 428)
@@ -0,0 +1,12 @@
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+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
+C
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOETHF.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOETHF.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOETHF.h	(revision 428)
@@ -0,0 +1,12 @@
+C*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+C
+C     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+C                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+C                ICE(*R_IES*).
+C     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+C     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+C
+      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/IPSL-CM4_v1x1/libf/phylmd/YOETHF.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOETHF.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOETHF.inc	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/YOMCST.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOMCST.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOMCST.h	(revision 428)
@@ -0,0 +1,33 @@
+! 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
+     S      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA
+     s      ,R_ecc, R_peri, R_incl
+     S      ,RA    ,RG    ,R1SA
+     S      ,RSIGMA,RI0
+     S      ,R     ,RMD   ,RMV   ,RD    ,RV    ,RCPD
+     S      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV
+     S      ,RCW   ,RCS
+     S      ,RLVTT ,RLSTT ,RLMLT ,RTT   ,RATM
+     S      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS
+     S      ,RALPD ,RBETD ,RGAMD
+!    ------------------------------------------------------------------
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOMCST.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOMCST.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/YOMCST.inc	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/ajsec.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ajsec.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ajsec.F	(revision 428)
@@ -0,0 +1,240 @@
+      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+c
+      INTEGER limbas, limhau ! les couches a ajuster
+ccc      PARAMETER (limbas=klev-3, limhau=klev)
+      PARAMETER (limbas=1, limhau=klev)
+c
+      LOGICAL mixq
+ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+c
+      REAL zh(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = limbas+1, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 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
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement sec (adaptation du GCM du LMD)
+c======================================================================
+c Arguments:
+c t-------input-R- Temperature
+c
+c d_t-----output-R-Incrementation de la temperature
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL d_t(klon,klev)
+c
+      REAL local_h(klon,klev)
+      REAL hm, sm
+      LOGICAL modif(klon), down
+      INTEGER i, l, l1, l2
+c------------------------------------- detection des profils a modifier
+      DO i = 1, klon
+         modif(i)   = .false.
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
+      ENDDO
+      ENDDO
+c
+      DO l = 2, klev
+      DO i = 1, klon
+         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
+            modif(i) = .true.
+         ELSE
+            modif(i) = modif(i)
+         ENDIF
+      ENDDO
+      ENDDO
+c------------------------------------- correction des profils instables
+      do 1080 i = 1, klon
+        if (modif(i)) then
+          l2 = 1
+ 8000     continue
+            l2 = l2 + 1
+            if (l2 .gt. klev) goto 8001
+            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
+              l1 = l2 - 1
+              l  = l1
+              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
+              hm = local_h(i, l2)
+ 8020         continue
+                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+     .                         * (local_h(i, l) - hm) / sm
+                down = .false.
+                if (l1 .ne. 1) then
+                  if (hm .lt. local_h(i, l1-1)) then
+                    down = .true.
+                  end if
+                end if
+                if (down) then
+                  l1 = l1 - 1
+                  l  = l1
+                else
+                  if ((l2 .eq. klev)) GOTO 8021
+                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
+                  l2 = l2 + 1
+                  l  = l2
+                end if
+              go to 8020
+ 8021         continue
+c------------ nouveau profil : constant (valeur moyenne)
+              do 1100 l = l1, l2
+                local_h(i, l) = hm
+ 1100         continue
+              l2 = l2 + 1
+            end if
+          go to 8000
+ 8001     continue
+        end if
+ 1080 continue
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/albedo.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/albedo.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/albedo.F	(revision 428)
@@ -0,0 +1,204 @@
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c Date: le 16 mars 1995
+c Objet: Calculer l'albedo sur l'ocean
+c Methode: Integrer numeriquement l'albedo pendant une journee
+c
+c Arguments;
+c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+c rlat (in,R)   : latitude en degre
+c albedo (out,R): albedo obtenu (de 0 a 1)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+cccIM   PARAMETER (fmagic=1.1)
+c       PARAMETER (fmagic=1.0)
+        PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      alb = 0.058/(rmu + 0.30)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(FLOAT(k)/FLOAT(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         alb = 0.058/(rmu + 0.30)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END
+c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940624
+c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+C on radiation in the atmosphere, 19-28 August 1976, science Press,
+C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+c
+c Arguments
+c rmu0    (in): cosinus de l'angle solaire zenithal
+c albedo (out): albedo de surface de l'ocean
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+      REAL rmu0(klon), albedo(klon)
+c
+      REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+cccIM   PARAMETER (fmagic=1.1)
+c       PARAMETER (fmagic=1.0)
+        PARAMETER (fmagic=0.7) 
+c
+      REAL fauxo
+      INTEGER i
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      DO i = 1, klon
+c
+         rmu0(i) = MAX(rmu0(i),0.0)
+c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+         albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+      ENDIF
+c
+      RETURN
+      END
+c========================================================================
+      SUBROUTINE albsno(veget, agesno, alb_neig)
+      IMPLICIT none
+c
+#include "dimensions.h"
+#include "dimphy.h"
+      INTEGER nvm
+      PARAMETER (nvm=8)
+      REAL veget(klon,nvm)
+      REAL alb_neig(klon)
+      REAL agesno(klon)
+c
+      INTEGER i, nv
+c
+      REAL init(nvm), decay(nvm), as
+      SAVE init, decay
+      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./
+c
+      DO i = 1, klon
+         alb_neig(i) = 0.0
+      ENDDO
+      DO nv = 1, nvm
+         DO i = 1, klon
+            as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+            alb_neig(i) = alb_neig(i) + veget(i,nv)*as
+         ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/atm2geo.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/atm2geo.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/atm2geo.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/calcratqs.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/calcratqs.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/calcratqs.F	(revision 428)
@@ -0,0 +1,160 @@
+c $Header$
+      SUBROUTINE calcratqs ( flag_ratqs,
+     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,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)
+
+	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                +1.5*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/IPSL-CM4_v1x1/libf/phylmd/clcdrag.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clcdrag.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clcdrag.F90	(revision 428)
@@ -0,0 +1,101 @@
+      SUBROUTINE clcdrag(klon, knon, nsrf, zxli, &
+                         u, v, t, q, zgeop, &
+                         ts, qsurf, rugos, &
+                         pcfm, pcfh)
+      IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.inc
+! zxli----input-L- calcul des cdrags selon Laurent Li
+! u-------input-R- vent zonal au 1er niveau du modele
+! v-------input-R- vent meridien au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, intent(in), dimension(klon) :: u, v, t, q, zgeop
+      REAL, intent(in), dimension(klon) :: ts, qsurf
+      REAL, intent(in), dimension(klon) :: rugos
+      REAL, intent(out), dimension(klon) :: pcfm, pcfh
+! ================================================================= c
+!
+#include "YOMCST.inc"
+#include "YOETHF.inc"
+#include "indicesol.inc"
+!
+! Quelques constantes et options:
+      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL :: zdu2, ztsolv, ztvd, zscf
+      REAL :: zucf, zcr
+      REAL :: friv, frih
+      REAL, dimension(klon) :: zcfm1, zcfm2
+      REAL, dimension(klon) :: zcfh1, zcfh2
+      REAL, dimension(klon) :: zcdn
+      REAL, dimension(klon) :: zri
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+      DO i = 1, knon
+        zdu2 = max(cepdu2,u(i)**2+v(i)**2)
+        ztsolv = ts(i) * (1.0+RETV*qsurf(i))
+        ztvd = (t(i)+zgeop(i)/RCPD/(1.+RVTMP2*q(i))) &
+             *(1.+RETV*q(i))
+        zri(i) = zgeop(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+        zcdn(i) = (ckap/log(1.+zgeop(i)/(RG*rugos(i))))**2
+!
+        IF (zri(i) .ge. 0.) THEN      ! situation stable
+          zri(i) = min(20.,zri(i))
+          IF (.NOT.zxli) THEN
+            zscf = SQRT(1.+cd*ABS(zri(i)))
+            FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+            zcfm1(i) = zcdn(i) * FRIV
+            FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+            zcfh1(i) = zcdn(i) * FRIH
+            pcfm(i) = zcfm1(i)
+            pcfh(i) = zcfh1(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fsta(zri(i))
+            pcfh(i) = zcdn(i)* fsta(zri(i))
+          ENDIF
+        ELSE                          ! situation instable
+          IF (.NOT.zxli) THEN
+            zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                 *(1.0+zgeop(i)/(RG*rugos(i)))))
+            zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+            pcfm(i) = zcfm2(i)
+            pcfh(i) = zcfh2(i)
+          ELSE
+            pcfm(i) = zcdn(i)* fins(zri(i))
+            pcfh(i) = zcdn(i)* fins(zri(i))
+          ENDIF
+          zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+          IF(nsrf.EQ.is_oce) pcfh(i) = zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+        ENDIF
+      END DO
+      RETURN
+      END SUBROUTINE clcdrag
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clesphys.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clesphys.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clesphys.h	(revision 428)
@@ -0,0 +1,9 @@
+c..include cles_phys.h
+c
+       LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf 
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con
+
+       COMMON/clesphys/cycle_diurne, soil_model, new_oliq ,
+     ,     ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con
+c
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clift.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clift.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clift.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/clim.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clim.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clim.h	(revision 428)
@@ -0,0 +1,109 @@
+C
+C     - - - - - - - - - - - - - - - - - - - - - - - - -
+C
+C*    =clim.h=  CLIM 1.1 include file 
+C	        Coupling Library for Interfacing Models
+C
+C     - - - - - - - - - - - - - - - - - - - - - - - - -
+C
+      INTEGER*4 CLIM_Void
+C
+      INTEGER*4	CLIM_MaxMod,
+     *          CLIM_MaxPort,   
+     *          CLIM_MaxSegments,
+     *          CLIM_MaxTag,
+     *          CLIM_MaxLink,
+     *          CLIM_ParSize,
+     *          CLIM_Clength
+C
+      INTEGER*4 CLIM_In,        CLIM_Out,       CLIM_InOut
+C
+      INTEGER*4 CLIM_Strategy,  CLIM_Serial,
+     *          CLIM_Apple,     CLIM_Orange,    CLIM_Box,
+     *          CLIM_Segments,  CLIM_Length,    CLIM_Offset,
+     *          CLIM_SizeX,     CLIM_SizeY,     CLIM_LdX
+C
+      INTEGER*4 CLIM_Integer,   CLIM_Real,      CLIM_Double
+C
+      INTEGER*4 CLIM_StopPvm,   CLIM_ContPvm
+C
+      INTEGER*4	CLIM_MaxCodes,  CLIM_Ok,
+     *          CLIM_FastExit,  CLIM_BadName,   CLIM_BadPort,
+     *          CLIM_BadType,   CLIM_DoubleDef, CLIM_NotStep,
+     *          CLIM_IncStep,   CLIM_IncSize,   CLIM_NotClim,
+     *          CLIM_TimeOut,
+     *          CLIM_Pvm,       CLIM_FirstCall, CLIM_PbRoute,
+     *          CLIM_Group,     CLIM_BadTaskId, CLIM_NoTask,
+     *          CLIM_InitBuff,  CLIM_Pack,      CLIM_Unpack,
+     *          CLIM_Down,      CLIM_PvmExit
+C
+C-----Parameter sizes
+C
+      PARAMETER ( CLIM_Void    = 0  )
+      PARAMETER ( CLIM_MaxMod  = 8 )
+      PARAMETER ( CLIM_MaxPort = 40 )
+      PARAMETER ( CLIM_MaxSegments = 160 )
+      PARAMETER ( CLIM_MaxLink = CLIM_MaxMod * CLIM_MaxPort )
+      PARAMETER ( CLIM_ParSize = 2 * CLIM_MaxSegments + 2 )
+      PARAMETER ( CLIM_MaxTag  = 16777215 )
+      PARAMETER ( CLIM_Clength = 32 )
+C
+C-----Ports status
+C
+      PARAMETER ( CLIM_In      = 1 )
+      PARAMETER ( CLIM_Out     = 0 )
+      PARAMETER ( CLIM_InOut   = 2 )
+C
+C-----Parallel distribution
+C
+      PARAMETER ( CLIM_Strategy = 1 )
+      PARAMETER ( CLIM_Segments = 2 )
+      PARAMETER ( CLIM_Serial   = 0 )
+      PARAMETER ( CLIM_Apple    = 1 )
+      PARAMETER ( CLIM_Box      = 2 )
+      PARAMETER ( CLIM_Orange   = 3 )
+      PARAMETER ( CLIM_Offset   = 2 )
+      PARAMETER ( CLIM_Length   = 3 )
+      PARAMETER ( CLIM_SizeX    = 3 )
+      PARAMETER ( CLIM_SizeY    = 4 )
+      PARAMETER ( CLIM_LdX      = 5 )
+C
+C-----Datatypes
+C
+      PARAMETER ( CLIM_Integer = 1 )
+      PARAMETER ( CLIM_Real    = 4 ) 
+      PARAMETER ( CLIM_Double  = 8 )
+C
+C-----Quit parameters
+C
+      PARAMETER ( CLIM_ContPvm = 0 )
+      PARAMETER ( CLIM_StopPvm = 1 )
+C
+C-----Error Codes
+C
+      PARAMETER ( CLIM_MaxCodes  = -21 )
+C
+      PARAMETER ( CLIM_Ok        = 0 )
+      PARAMETER ( CLIM_FastExit  = -1 )
+      PARAMETER ( CLIM_BadName   = -2 )
+      PARAMETER ( CLIM_BadPort   = -3 )
+      PARAMETER ( CLIM_BadType   = -4 )
+      PARAMETER ( CLIM_DoubleDef = -5 )
+      PARAMETER ( CLIM_NotStep   = -6 )
+      PARAMETER ( CLIM_IncStep   = -7 )
+      PARAMETER ( CLIM_IncSize   = -8 )
+      PARAMETER ( CLIM_NotClim   = -9 )
+      PARAMETER ( CLIM_TimeOut   = -10 )
+      PARAMETER ( CLIM_Pvm       = -11 )
+      PARAMETER ( CLIM_FirstCall = -12 )
+      PARAMETER ( CLIM_PbRoute   = -13 )
+      PARAMETER ( CLIM_Group     = -14 )
+      PARAMETER ( CLIM_BadTaskId = -15 )
+      PARAMETER ( CLIM_NoTask    = -16 )
+      PARAMETER ( CLIM_InitBuff  = -17 )
+      PARAMETER ( CLIM_Pack      = -18 )
+      PARAMETER ( CLIM_Unpack    = -19 )
+      PARAMETER ( CLIM_Down      = -20 )
+      PARAMETER ( CLIM_PvmExit   = -21 )
+C
+C-----End of clim.h
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clmain.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clmain.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clmain.F	(revision 428)
@@ -0,0 +1,2021 @@
+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,
+     .                  dflux_t,dflux_q,
+     .                  zcoefh,zu1,zv1, t2m, q2m, u10m, v10m)
+cAA .                  itr, tr, flux_surf, d_tr)
+cAA REM:
+cAA-----
+cAA Tout ce qui a trait au traceurs est dans phytrac maintenant
+cAA pour l'instant le calcul de la couche limite pour les traceurs
+cAA se fait avec cltrac et ne tient pas compte de la differentiation
+cAA des sous-fraction de sol.
+cAA REM bis :
+cAA----------
+cAA Pour pouvoir extraire les coefficient d'echanges et le vent 
+cAA dans la premiere couche, 3 champs supplementaires ont ete crees
+cAA zcoefh,zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
+cAA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
+cAA si les informations des subsurfaces doivent etre prises en compte
+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======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: interface de "couche limite" (diffusion verticale)
+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)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c ts-------input-R- temperature du sol (en Kelvin)
+c paprs----input-R- pression a intercouche (Pa)
+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 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"
+c d_q------output-R- le changement pour "q"
+c d_u------output-R- le changement pour "u"
+c d_v------output-R- le changement pour "v"
+c d_ts-----output-R- le changement pour "ts"
+c flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
+c                    (orientation positive vers le bas)
+c flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
+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 dflux_t derive du flux sensible
+c dflux_q derive du flux latent
+cAA on rajoute en output yu1 et yv1 qui sont les vents dans 
+cAA la premiere couche
+cAA ces 4 variables sont maintenant traites dans phytrac
+c itr--------input-I- nombre de traceurs
+c tr---------input-R- q. de traceurs
+c flux_surf--input-R- flux de traceurs a la surface
+c d_tr-------output-R tendance de traceurs
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "indicesol.h"
+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 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, nbsrf), flux_q(klon,klev, nbsrf)
+      REAL dflux_t(klon), dflux_q(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)
+cAA      REAL d_tr(klon,klev,nbtr)
+cAA      REAL flux_surf(klon,nbtr)
+c
+      REAL pctsrf(klon,nbsrf)
+      REAL ts(klon,nbsrf)
+      REAL d_ts(klon,nbsrf)
+      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)
+      REAL zu1(klon)
+      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), yz0_new(klon)
+      REAL yalb(klon)
+      REAL yalblw(klon)
+      REAL yu1(klon), yv1(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)
+      REAL y_d_u(klon, klev), y_d_v(klon, klev)
+      REAL y_flux_t(klon,klev), y_flux_q(klon,klev)
+      REAL y_flux_u(klon,klev), y_flux_v(klon,klev)
+      REAL y_dflux_t(klon), y_dflux_q(klon)
+      REAL ycoefh(klon,klev), ycoefm(klon,klev)
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev), ydelp(klon,klev)
+cAA      REAL ytr(klon,klev,nbtr)
+cAA      REAL y_d_tr(klon,klev,nbtr)
+cAA      REAL yflxsrf(klon,nbtr)
+c
+      LOGICAL contreg
+      PARAMETER (contreg=.TRUE.)
+c
+      LOGICAL ok_nonloc
+      PARAMETER (ok_nonloc=.FALSE.)
+      REAL ycoefm0(klon,klev), ycoefh0(klon,klev)
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      REAL u1lay(klon), v1lay(klon)
+      REAL delp(klon,klev)
+      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./
+      integer idayref
+#include "temps.h"
+      REAL t2m(klon,nbsrf), q2m(klon,nbsrf)
+      REAL u10m(klon,nbsrf), v10m(klon,nbsrf)
+c
+      REAL yt2m(klon), yq2m(klon), yu10m(klon)
+c
+      REAL uzon(klon), vmer(klon)
+      REAL tair1(klon), qair1(klon), tairsol(klon)
+      REAL psfce(klon), patm(klon)
+c
+      REAL qairsol(klon), zgeo1(klon)
+      REAL rugo1(klon)
+c
+      LOGICAL zxli ! utiliser un jeu de fonctions simples
+      PARAMETER (zxli=.FALSE.)
+c
+      REAL zt, zqs, zdelta, zcor
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+C
+      PRINT*,'IMclmain klon=',klon
+      IF (first_appel) THEN
+          first_appel=.false.
+!
+! initialisation sorties netcdf
+!
+          idayref = day_ini
+          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+          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(:,1),jjm+1,zx_lat(1,:),
+     $        1,iim,1,jjm
+     $        +1, itau_phy,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
+         delp(i,k) = paprs(i,k)-paprs(i,k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon  ! vent de la premiere couche
+ccc         zx_alf1 = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf1 = 1.0
+         zx_alf2 = 1.0 - zx_alf1
+         u1lay(i) = u(i,1)*zx_alf1 + u(i,2)*zx_alf2
+         v1lay(i) = v(i,1)*zx_alf1 + v(i,2)*zx_alf2
+      ENDDO
+c
+c initialisation:
+c
+      DO i = 1, klon
+         rugmer(i) = 0.0
+         cdragh(i) = 0.0
+         cdragm(i) = 0.0
+         dflux_t(i) = 0.0
+         dflux_q(i) = 0.0
+         zu1(i) = 0.0
+         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
+      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
+      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
+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
+c$$$         flux_u(i,k) = 0.0
+c$$$         flux_v(i,k) = 0.0
+         zcoefh(i,k) = 0.0
+      ENDDO
+      ENDDO
+cAA      IF (itr.GE.1) THEN
+cAA      DO it = 1, itr
+cAA      DO k = 1, klev
+cAA      DO i = 1, klon
+cAA         d_tr(i,k,it) = 0.0
+cAA      ENDDO
+cAA      ENDDO
+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
+       totalflu = radsol
+
+c chercher les indices:
+      DO j = 1, klon
+         ni(j) = 0
+      ENDDO
+      knon = 0
+      DO i = 1, klon
+
+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
+      ENDIF
+      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
+      i = ni(j)
+        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)
+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)
+      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
+      i = ni(j)
+        ypaprs(j,k) = paprs(i,k)
+        ypplay(j,k) = pplay(i,k)
+        ydelp(j,k) = delp(i,k)
+        yu(j,k) = u(i,k)
+        yv(j,k) = v(i,k)
+        yt(j,k) = t(i,k)
+        yq(j,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+c
+c calculer Cdrag et les coefficients d'echange
+      CALL coefkz(nsrf, knon, ypaprs, ypplay,
+     .            yts, yrugos, yu, yv, yt, yq,
+     .            ycoefm, ycoefh)
+      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"
+      CALL clvent(knon,dtime,yu1,yv1,ycoefm,yt,yu,ypaprs,ypplay,ydelp,
+     s            y_d_u,y_flux_u)
+      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 FH modif sur le cdrag temperature
+      do i=1,knon
+         ycoefh(i,1)=ycoefm(i,1)*0.8
+      enddo
+
+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
+         yrugm(j) = 0.018*ycoefm(j,1) * (yu1(j)**2+yv1(j)**2)/RG
+         yrugm(j) = MAX(1.5e-05,yrugm(j))
+      ENDDO
+      ENDIF
+      DO j = 1, knon
+         y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+         y_dflux_q(j) = y_dflux_q(j) * ypct(j)
+         yu1(j) = yu1(j) *  ypct(j)
+         yv1(j) = yv1(j) *  ypct(j)
+      ENDDO
+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
+         i = ni(j)
+         d_ts(i,nsrf) = y_d_ts(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(j)
+         endif	
+         cdragh(i) = cdragh(i) + ycoefh(j,1)
+         cdragm(i) = cdragm(i) + ycoefm(j,1)
+         dflux_t(i) = dflux_t(i) + y_dflux_t(j)
+         dflux_q(i) = dflux_q(i) + y_dflux_q(j)
+         zu1(i) = zu1(i) + yu1(j)
+         zv1(i) = zv1(i) + yv1(j)
+      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
+      DO k = 1, klev
+      DO j = 1, knon
+      i = ni(j)
+#else
+      DO j = 1, knon
+      i = ni(j)
+      DO k = 1, klev
+#endif
+         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)
+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)
+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
+c
+#undef T2m     
+#ifdef T2m
+ccc diagnostic t,q a 2m et u, v a 10m
+c
+      DO j=1, knon
+        i = ni(j)
+        uzon(j) = yu(j,1) + y_d_u(j,1)
+        vmer(j) = yv(j,1) + y_d_v(j,1)
+        tair1(j) = yt(j,1) + y_d_t(j,1)
+        qair1(j) = yq(j,1) + y_d_q(j,1)
+        zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1)))
+     &                   * (ypaprs(j,1)-ypplay(j,1))
+        tairsol(j) = yts(j) + y_d_ts(j)
+        rugo1(j) = yrugos(j)
+        IF(nsrf.EQ.is_oce) THEN
+         rugo1(j) = rugos(i,nsrf)
+        ENDIF
+        psfce(j)=ypaprs(j,1)
+        patm(j)=ypplay(j,1)
+c
+        IF (nsrf.EQ.1) THEN
+          qairsol(j) = yqsol(j)
+        ELSE IF(nsrf.GT.1) THEN
+         zt = ts(i,nsrf)
+         IF (thermcep) THEN
+           zdelta = MAX(0.,SIGN(1.,RTT-zt))
+           zqs = R2ES * FOEEW(zt,zdelta) / ypplay(j,1)
+           zqs = MIN(0.5,zqs)
+           zcor = 1./(1.-RETV*zqs)
+           zqs = zqs*zcor
+         ELSE
+           IF (zt .LT. t_coup) THEN
+             zqs = qsats(zt) / ypplay(j,1)
+           ELSE
+             zqs = qsatl(zt) / ypplay(j,1)
+           ENDIF
+         ENDIF   
+         qairsol(j) = zqs
+        ENDIF   
+      ENDDO
+c
+      IF(nsrf.EQ.3) THEN
+       j=1465
+       WRITE(*,*)' INstO',klon,knon,nsrf,zxli,uzon(j),vmer(j), 
+     & tair1(j),qair1(j),zgeo1(j),tairsol(j),qairsol(j),rugo1(j),
+     & psfce(j),patm(j)
+      ENDIF
+c
+      CALL stdlevvar(klon, knon, nsrf, zxli,
+     &               uzon, vmer, tair1, qair1, zgeo1,
+     &               tairsol, qairsol, rugo1, psfce, patm,
+     &               yt2m, yq2m, yu10m)
+
+c
+      IF(nsrf.EQ.3) THEN
+       j=1465
+       WRITE(*,*)' OUstd',klon,knon,nsrf,zxli,uzon(j),vmer(j), 
+     & tair1(j),qair1(j),zgeo1(j),tairsol(j),qairsol(j),rugo1(j),
+     & psfce(j),patm(j)
+       WRITE(*,*)' tqu',yt2m(j),yq2m(j),yu10m(j)
+      ENDIF
+c
+      DO j=1, knon
+       i = ni(j)
+       t2m(i,nsrf)=yt2m(j)
+
+        IF(nsrf.EQ.3) THEN
+         IF(j.EQ.1465) THEN
+         WRITE(*,*) 't2m APRES stdlev',j,i,tair1(j),t2m(i,nsrf),
+     $   tairsol(j),rlon(i),rlat(i)
+         ENDIF
+        ENDIF
+c
+       q2m(i,nsrf)=yq2m(j)
+c
+c u10m, v10m : composantes du vent a 10m sans spirale de Ekman
+       u10m(i,nsrf)=(yu10m(j) * uzon(j))/sqrt(uzon(j)**2+vmer(j)**2)
+       v10m(i,nsrf)=(yu10m(j) * vmer(j))/sqrt(uzon(j)**2+vmer(j)**2)
+c
+      ENDDO
+#else
+       DO j=1, knon
+         t2m(i,nsrf)=0.
+         q2m(i,nsrf)=0.
+         u10m(i,nsrf)=0.
+         v10m(i,nsrf)=0.
+       ENDDO 
+#endif
+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(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======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: diffusion verticale de "q" et de "h"
+c======================================================================
+#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)
+      REAL coef(klon,klev)    ! le coefficient d'echange (m**2/s)
+c                               multiplie par le cisaillement du 
+c                               vent (dV/dz); la premiere valeur
+c                               indique la valeur de Cdrag (sans unite)
+      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"
+      REAL d_q(klon,klev)     ! incrementation de "q"
+      REAL d_ts(klon)         ! incrementation de "ts"
+      REAL flux_t(klon,klev)  ! (diagnostic) flux de la chaleur
+c                               sensible, flux de Cp*T, positif vers
+c                               le bas: j/(m**2 s) c.a.d.: W/m2
+      REAL flux_q(klon,klev)  ! flux de la vapeur d'eau:kg/(m**2 s)
+      REAL dflux_s(klon) ! derivee du flux sensible dF/dTs
+      REAL dflux_l(klon) ! derivee du flux latent dF/dTs
+c======================================================================
+      REAL t_grnd  ! temperature de rappel pour glace de mer
+      PARAMETER (t_grnd=271.35)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+c======================================================================
+      INTEGER i, k
+      REAL zx_cq(klon,klev)
+      REAL zx_dq(klon,klev)
+      REAL zx_ch(klon,klev)
+      REAL zx_dh(klon,klev)
+      REAL zx_buf1(klon)
+      REAL zx_buf2(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_h(klon,klev) ! enthalpie potentielle
+      REAL local_q(klon,klev)
+      REAL local_ts(klon)
+      REAL psref(klon) ! pression de reference pour temperature potent.
+      REAL zx_pkh(klon,klev), zx_pkf(klon,klev)
+c======================================================================
+c contre-gradient pour la vapeur d'eau: (kg/kg)/metre
+      REAL gamq(klon,2:klev)
+c contre-gradient pour la chaleur sensible: Kelvin/metre
+      REAL gamt(klon,2:klev)
+      REAL z_gamaq(klon,2:klev), z_gamah(klon,2:klev)
+      REAL zdelz
+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 JLD
+      real zzpk
+      
+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)
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, knon
+         zx_pkh(i,k) = (psref(i)/paprs(i,k))**RKAPPA
+         zx_pkf(i,k) = (psref(i)/pplay(i,k))**RKAPPA
+         local_h(i,k) = RCPD * t(i,k) * zx_pkf(i,k)
+         local_q(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+c
+c Convertir les coefficients en variables convenables au calcul:
+c
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c
+c Preparer les flux lies aux contre-gardients
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         zdelz = RD * (t(i,k-1)+t(i,k))/2.0 / RG /paprs(i,k)
+     .              *(pplay(i,k-1)-pplay(i,k))
+         z_gamaq(i,k) = gamq(i,k) * zdelz
+         z_gamah(i,k) = gamt(i,k) * zdelz *RCPD * zx_pkh(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, knon
+         zx_buf1(i) = zx_coef(i,klev) + delp(i,klev)
+         zx_cq(i,klev) = (local_q(i,klev)*delp(i,klev)
+     .                   -zx_coef(i,klev)*z_gamaq(i,klev))/zx_buf1(i)
+         zx_dq(i,klev) = zx_coef(i,klev) / zx_buf1(i)
+c
+         zzpk=(pplay(i,klev)/psref(i))**RKAPPA
+         zx_buf2(i) = zzpk*delp(i,klev) + zx_coef(i,klev)
+         zx_ch(i,klev) = (local_h(i,klev)*zzpk*delp(i,klev)
+     .                   -zx_coef(i,klev)*z_gamah(i,klev))/zx_buf2(i)
+         zx_dh(i,klev) = zx_coef(i,klev) / zx_buf2(i)
+      ENDDO
+      DO k = klev-1, 2 , -1
+      DO i = 1, knon
+         zx_buf1(i) = delp(i,k)+zx_coef(i,k)
+     .               +zx_coef(i,k+1)*(1.-zx_dq(i,k+1))
+         zx_cq(i,k) = (local_q(i,k)*delp(i,k)
+     .                 +zx_coef(i,k+1)*zx_cq(i,k+1)
+     .                 +zx_coef(i,k+1)*z_gamaq(i,k+1)
+     .                 -zx_coef(i,k)*z_gamaq(i,k))/zx_buf1(i)
+         zx_dq(i,k) = zx_coef(i,k) / zx_buf1(i)
+c
+         zzpk=(pplay(i,k)/psref(i))**RKAPPA
+         zx_buf2(i) = zzpk*delp(i,k)+zx_coef(i,k)
+     .               +zx_coef(i,k+1)*(1.-zx_dh(i,k+1))
+         zx_ch(i,k) = (local_h(i,k)*zzpk*delp(i,k)
+     .                 +zx_coef(i,k+1)*zx_ch(i,k+1)
+     .                 +zx_coef(i,k+1)*z_gamah(i,k+1)
+     .                 -zx_coef(i,k)*z_gamah(i,k))/zx_buf2(i)
+         zx_dh(i,k) = zx_coef(i,k) / zx_buf2(i)
+      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_cq(i,1) = (local_q(i,1)*delp(i,1)
+     .                 +zx_coef(i,2)*(z_gamaq(i,2)+zx_cq(i,2)))
+     .                /zx_buf1(i)
+         zx_dq(i,1) = -1. * RG / zx_buf1(i)
+c
+         zzpk=(pplay(i,1)/psref(i))**RKAPPA
+         zx_buf2(i) = zzpk*delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2))
+         zx_ch(i,1) = (local_h(i,1)*zzpk*delp(i,1)
+     .                 +zx_coef(i,2)*(z_gamah(i,2)+zx_ch(i,2)))
+     .                /zx_buf2(i)
+         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
+         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
+      DO i = 1, knon
+        local_q(i,k) = zx_cq(i,k) + zx_dq(i,k)*local_q(i,k-1)
+        local_h(i,k) = zx_ch(i,k) + zx_dh(i,k)*local_h(i,k-1)
+      ENDDO
+      ENDDO
+c======================================================================
+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 k = 2, klev
+      DO i = 1, knon
+        flux_q(i,k) = (zx_coef(i,k)/RG/dtime)
+     .                * (local_q(i,k)-local_q(i,k-1)+z_gamaq(i,k))
+        flux_t(i,k) = (zx_coef(i,k)/RG/dtime)
+     .                * (local_h(i,k)-local_h(i,k-1)+z_gamah(i,k))
+     .                / zx_pkh(i,k)
+      ENDDO
+      ENDDO
+c======================================================================
+C Calcul tendances
+      DO k = 1, klev
+      DO i = 1, knon
+         d_t(i,k) = local_h(i,k)/zx_pkf(i,k)/RCPD - t(i,k)
+         d_q(i,k) = local_q(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+
+      RETURN
+      END
+      SUBROUTINE clvent(knon,dtime, u1lay,v1lay,coef,t,ven,
+     e                  paprs,pplay,delp,
+     s                  d_ven,flux_v)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: diffusion vertical de la vitesse "ven"
+c======================================================================
+c Arguments:
+c dtime----input-R- intervalle du temps (en second)
+c u1lay----input-R- vent u de la premiere couche (m/s)
+c v1lay----input-R- vent v de la premiere couche (m/s)
+c coef-----input-R- le coefficient d'echange (m**2/s) multiplie par
+c                   le cisaillement du vent (dV/dz); la premiere
+c                   valeur indique la valeur de Cdrag (sans unite)
+c t--------input-R- temperature (K)
+c ven------input-R- vitesse horizontale (m/s)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c
+c
+c d_ven----output-R- le changement de "ven"
+c flux_v---output-R- (diagnostic) flux du vent: (kg m/s)/(m**2 s)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+      INTEGER knon
+      REAL dtime
+      REAL u1lay(klon), v1lay(klon)
+      REAL coef(klon,klev)
+      REAL t(klon,klev), ven(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL d_ven(klon,klev)
+      REAL flux_v(klon,klev)
+c======================================================================
+#include "YOMCST.h"
+c======================================================================
+      INTEGER i, k
+      REAL zx_cv(klon,2:klev)
+      REAL zx_dv(klon,2:klev)
+      REAL zx_buf(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_ven(klon,klev)
+      REAL zx_alf1(klon), zx_alf2(klon)
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, knon
+         local_ven(i,k) = ven(i,k)
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, knon
+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)
+         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
+      DO i = 1, knon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, knon
+         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i)+zx_coef(i,2)
+         zx_cv(i,2) = local_ven(i,1)*delp(i,1) / zx_buf(i)
+         zx_dv(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1))
+     .                /zx_buf(i)
+      ENDDO
+      DO k = 3, klev
+      DO i = 1, knon
+         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
+     .                         + zx_coef(i,k-1)*(1.-zx_dv(i,k-1))
+         zx_cv(i,k) = (local_ven(i,k-1)*delp(i,k-1)
+     .                  +zx_coef(i,k-1)*zx_cv(i,k-1) )/zx_buf(i)
+         zx_dv(i,k) = zx_coef(i,k)/zx_buf(i)
+      ENDDO
+      ENDDO
+      DO i = 1, knon
+         local_ven(i,klev) = ( local_ven(i,klev)*delp(i,klev)
+     .                        +zx_coef(i,klev)*zx_cv(i,klev) )
+     .                   / ( delp(i,klev) + zx_coef(i,klev)
+     .                       -zx_coef(i,klev)*zx_dv(i,klev) )
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, knon
+         local_ven(i,k) = zx_cv(i,k+1) + zx_dv(i,k+1)*local_ven(i,k+1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== flux_v est le flux de moment angulaire (positif vers bas)
+c== dont l'unite est: (kg m/s)/(m**2 s)
+      DO i = 1, knon
+         flux_v(i,1) = zx_coef(i,1)/(RG*dtime)
+     .                 *(local_ven(i,1)*zx_alf1(i)
+     .                  +local_ven(i,2)*zx_alf2(i))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         flux_v(i,k) = zx_coef(i,k)/(RG*dtime)
+     .               * (local_ven(i,k)-local_ven(i,k-1))
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, knon
+         d_ven(i,k) = local_ven(i,k) - ven(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE coefkz(nsrf, knon, paprs, pplay,
+     .                  ts, rugos,
+     .                  u,v,t,q,
+     .                  pcfm, pcfh)
+      IMPLICIT none
+c======================================================================
+c Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+c           (une version strictement identique a l'ancien modele)
+c Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+c        coefficients d'echange turbulent dans l'atmosphere.
+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 ts-------input-R- temperature du sol (en Kelvin)
+c rugos----input-R- longeur de rugosite (en m)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c
+c itop-----output-I- numero de couche du sommet de la couche limite
+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 ts(klon)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL u(klon,klev), v(klon,klev), t(klon,klev), q(klon,klev)
+      REAL rugos(klon)
+c
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+      INTEGER itop(klon)
+c
+c Quelques constantes et options:
+c
+      REAL cepdu2, ckap, cb, cc, cd, clam
+      PARAMETER (cepdu2 =(0.1)**2)
+      PARAMETER (CKAP=0.4)
+      PARAMETER (cb=5.0)
+      PARAMETER (cc=5.0)
+      PARAMETER (cd=5.0)
+      PARAMETER (clam=160.0)
+      REAL ratqs ! largeur de distribution de vapeur d'eau
+      PARAMETER (ratqs=0.05)
+      LOGICAL richum ! utilise le nombre de Richardson humide
+      PARAMETER (richum=.TRUE.)
+      REAL ric ! nombre de Richardson critique
+      PARAMETER(ric=0.4)
+      REAL prandtl
+      PARAMETER (prandtl=0.4)
+      REAL kstable ! diffusion minimale (situation stable)
+      PARAMETER (kstable=1.0e-10)
+      REAL mixlen ! constante controlant longueur de melange
+      PARAMETER (mixlen=35.0)
+      INTEGER isommet ! le sommet de la couche limite
+      PARAMETER (isommet=klev)
+      LOGICAL tvirtu ! calculer Ri d'une maniere plus performante
+      PARAMETER (tvirtu=.TRUE.)
+      LOGICAL opt_ec ! formule du Centre Europeen dans l'atmosphere
+      PARAMETER (opt_ec=.FALSE.)
+      LOGICAL contreg ! utiliser le contre-gradient dans Ri
+      PARAMETER (contreg=.TRUE.)
+c
+c Variables locales:
+c
+      INTEGER i, k
+      REAL zgeop(klon,klev)
+      REAL zmgeom(klon)
+      REAL zri(klon)
+      REAL zl2(klon)
+
+      REAL u1(klon), v1(klon), t1(klon), q1(klon), z1(klon)
+      REAL pcfm1(klon), pcfh1(klon)
+c
+      REAL zdphi, zdu2, ztvd, ztvu, zcdn
+      REAL zscf
+      REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+      REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+      REAL t_coup
+      PARAMETER (t_coup=273.15)
+c
+c contre-gradient pour la chaleur sensible: Kelvin/metre
+      REAL gamt(2:klev)
+c essai qsurf
+      real qsurf(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c
+c Fonctions thermodynamiques et fonctions d'instabilite
+      REAL fsta, fins, x
+      LOGICAL zxli ! utiliser un jeu de fonctions simples
+      PARAMETER (zxli=.FALSE.)
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'coefkz, opt_ec:', opt_ec
+         PRINT*, 'coefkz, richum:', richum
+         IF (richum) PRINT*, 'coefkz, ratqs:', ratqs
+         PRINT*, 'coefkz, isommet:', isommet
+         PRINT*, 'coefkz, tvirtu:', tvirtu
+         appel1er = .FALSE.
+      ENDIF
+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
+      DO i = 1, knon
+         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 (.NOT.contreg) THEN
+         DO k = 2, klev
+            gamt(k) = 0.0
+         ENDDO
+      ELSE
+         DO k = 3, klev
+            gamt(k) = -1.0E-03
+         ENDDO
+         gamt(2) = -2.5E-03
+      ENDIF
+c
+c Calculer les geopotentiels de chaque couche
+c
+      DO i = 1, knon
+         zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                   * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         zgeop(i,k) = zgeop(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+c Calculer le frottement au sol (Cdrag)
+c
+c     DO i = 1, knon
+      DO i = 1, klon
+       u1(i) = u(i,1)
+       v1(i) = v(i,1)
+       t1(i) = t(i,1)
+       q1(i) = q(i,1)
+       z1(i) = zgeop(i,1)
+      ENDDO
+c
+      CALL clcdrag(klon, knon, nsrf, zxli, 
+     $             u1, v1, t1, q1, z1,
+     $             ts, qsurf, rugos,
+     $             pcfm1, pcfh1) 
+C
+      DO i = 1, knon
+       pcfm(i,1)=pcfm1(i)
+       pcfh(i,1)=pcfh1(i)
+      ENDDO
+c
+c Calculer les coefficients turbulents dans l'atmosphere
+c
+      DO i = 1, knon
+         itop(i) = isommet
+      ENDDO
+
+      PRINT*,' isommet=',isommet,' knon=',knon
+
+      DO k = 2, isommet
+      DO i = 1, knon
+            zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2
+     .                     +(v(i,k)-v(i,k-1))**2)
+            zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+            zdphi =zmgeom(i) / 2.0
+            zt = (t(i,k)+t(i,k-1)) * 0.5
+            zq = (q(i,k)+q(i,k-1)) * 0.5
+c
+c           calculer Qs et dQs/dT:
+c
+            IF (thermcep) THEN
+              zdelta = MAX(0.,SIGN(1.,RTT-zt))
+              zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) 
+     .            + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+              zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+              zqs = MIN(0.5,zqs)
+              zcor = 1./(1.-RETV*zqs)
+              zqs = zqs*zcor
+              zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+            ELSE
+              IF (zt .LT. t_coup) THEN
+                 zqs = qsats(zt) / pplay(i,k)
+                 zdqs = dqsats(zt,zqs)
+              ELSE
+                 zqs = qsatl(zt) / pplay(i,k)
+                 zdqs = dqsatl(zt,zqs)
+              ENDIF
+            ENDIF
+c
+c           calculer la fraction nuageuse (processus humide):
+c
+            zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+            zfr = MAX(0.0,MIN(1.0,zfr))
+            IF (.NOT.richum) zfr = 0.0
+c
+c           calculer le nombre de Richardson:
+c
+            IF (tvirtu) THEN
+            ztvd =( t(i,k)
+     .             + zdphi/RCPD/(1.+RVTMP2*zq)
+     .              *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) )
+     .            )*(1.+RETV*q(i,k))
+            ztvu =( t(i,k-1)
+     .             - zdphi/RCPD/(1.+RVTMP2*zq)
+     .              *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) )
+     .            )*(1.+RETV*q(i,k-1))
+            zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+            zri(i) = zri(i)
+     .             + zmgeom(i)*zmgeom(i)/RG*gamt(k)
+     .               *(paprs(i,k)/101325.0)**RKAPPA
+     .               /(zdu2*0.5*(ztvd+ztvu))
+c
+            ELSE ! calcul de Ridchardson compatible LMD5
+c
+            zri(i) =(RCPD*(t(i,k)-t(i,k-1))
+     .              -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k)
+     .               *(pplay(i,k)-pplay(i,k-1))
+     .              )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+            zri(i) = zri(i) +
+     .             zmgeom(i)*zmgeom(i)*gamt(k)/RG
+cSB     .             /(paprs(i,k)/101325.0)**RKAPPA
+     .             *(paprs(i,k)/101325.0)**RKAPPA
+     .             /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+            ENDIF
+c
+c           finalement, les coefficients d'echange sont obtenus:
+c
+            zcdn=SQRT(zdu2) / zmgeom(i) * RG
+c
+          IF (opt_ec) THEN
+            z2geomf=zgeop(i,k-1)+zgeop(i,k)
+            zalm2=(0.5*ckap/RG*z2geomf
+     .             /(1.+0.5*ckap/rg/clam*z2geomf))**2
+            zalh2=(0.5*ckap/rg*z2geomf
+     .             /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+            IF (zri(i).LT.0.0) THEN  ! situation instable
+               zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3
+     .                / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+               zscf = SQRT(-zri(i)*zscf)
+               zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+               zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+               pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+               pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+            ELSE ! situation stable
+               zscf=SQRT(1.+cd*zri(i))
+               pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+               pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+            ENDIF
+          ELSE
+            zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1))
+     .                          /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+            pcfm(i,k)=sqrt(max(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+            pcfm(i,k)= zl2(i)* pcfm(i,k)
+            pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+      ENDDO
+      ENDDO
+c
+c Au-dela du sommet, pas de diffusion turbulente:
+c
+      DO i = 1, knon
+         IF (itop(i)+1 .LE. klev) THEN
+            DO k = itop(i)+1, klev
+               pcfh(i,k) = 0.0
+               pcfm(i,k) = 0.0
+            ENDDO
+         ENDIF
+      ENDDO
+c
+      RETURN
+      END
+
+      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
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c date: 19940414
+c======================================================================
+c
+c Calculer quelques parametres pour appliquer la couche limite
+c ------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+      REAL tau_gl ! temps de relaxation pour la glace de mer
+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)
+c
+      REAL calsol, calsno, calice ! epaisseur du sol: 0.15 m
+      PARAMETER (calsol=1.0/(2.5578E+06*0.15))
+      PARAMETER (calsno=1.0/(2.3867E+06*0.15))
+      PARAMETER (calice=1.0/(5.1444E+06*0.15))
+C
+      INTEGER i
+c
+      REAL dtime
+      REAL snow(klon), qsol(klon)
+      INTEGER indice, knon
+C
+      REAL vbeta(klon)
+      REAL vcal(klon)
+      REAL vdif(klon)
+C
+
+      IF (indice.EQ.is_oce) THEN
+      DO i = 1, knon
+          vcal(i)   = 0.0
+          vbeta(i)  = 1.0
+          vdif(i) = 0.0
+      ENDDO
+      ENDIF
+c
+      IF (indice.EQ.is_sic) THEN
+      DO i = 1, knon
+          vcal(i) = calice
+          IF (snow(i) .GT. 0.0) vcal(i) = calsno
+          vbeta(i)  = 1.0
+          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, knon
+          vcal(i) = calsol
+          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
+      ENDIF
+c
+      IF (indice.EQ.is_lic) THEN
+      DO i = 1, knon
+          vcal(i) = calice
+          IF (snow(i) .GT. 0.0) vcal(i) = calsno
+          vbeta(i)  = 1.0
+          vdif(i) = 0.0
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+C======================================================================
+      SUBROUTINE nonlocal(knon, paprs, pplay,
+     .                    tsol,beta,u,v,t,q,
+     .                    cd_h, cd_m, pcfh, pcfm, cgh, cgq)
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL tsol(klon) ! temperature du sol (K)
+      REAL beta(klon) ! efficacite d'evaporation (entre 0 et 1)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+      PARAMETER (isommet=klev)
+      REAL vk
+      PARAMETER (vk=0.40)
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)
+      REAL fakn
+      PARAMETER (fakn=7.2)
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)
+      REAL sffrac
+      PARAMETER (sffrac=0.1)
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL z(klon,klev)
+      REAL pcfm(klon,klev), pcfh(klon,klev)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL ustar(klon)
+      REAL rino(klon,klev)  ! bulk Richardon no. from level to ref lev
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      REAL pblh(klon)
+      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)
+      REAL ztvd, ztvu, zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5, zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation
+c
+      DO i = 1, klon
+         pcfh(i,1) = cd_h(i)
+         pcfm(i,1) = cd_m(i)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pcfh(i,k) = zkmin
+         pcfm(i,k) = zkmin
+         cgs(i,k) = 0.0
+         cgh(i,k) = 0.0
+         cgq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+      ENDDO
+      ENDDO
+c
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+           zxqs=MIN(0.5,zxqs)
+           zcor=1./(1.-retv*zxqs)
+           zxqs=zxqs*zcor
+         ELSE
+           IF (tsol(i).LT.t_coup) THEN
+              zxqs = qsats(tsol(i)) / paprs(i,1)
+           ELSE
+              zxqs = qsatl(tsol(i)) / paprs(i,1)
+           ENDIF
+         ENDIF
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .        *(1.+RETV*q(i,1))*zx_alf1
+     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+     .        *(1.+RETV*q(i,2))*zx_alf2
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+        heatv(i) = khfs(i) + 0.61*zxt*kqfs(i)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+      ENDDO
+c
+      DO i = 1, knon
+         rino(i,1) = 0.0
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+      ENDDO
+
+C
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C
+      fac = 100.0
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+        wm(i)= ustar(i)*phiminv(i)
+        therm(i) = heatv(i)*fak/wm(i)
+        rino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+C Improve pblh estimate for unstable conditions using the
+C convective temperature excess:
+C
+      DO k = 1, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+         zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = max(zdu2,1.0e-20)
+         ztvd =(t(i,k)+z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,k)))
+     .         *(1.+RETV*q(i,k))
+         ztvu =(t(i,1)+therm(i)-z(i,k)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+         rino(i,k) = (z(i,k)-z(i,1))*RG*(ztvd-ztvu)
+     .               /(zdu2*0.5*(ztvd+ztvu))
+         IF (rino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rino(i,k-1))/(rino(i,k-1)-rino(i,k))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Points for which pblh exceeds number of pbl layers allowed;
+C set to maximum
+C
+      DO i = 1, knon
+        IF (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+      ENDDO
+C
+C pblh is now available; do preparation for diffusivity calculation:
+C
+      DO i = 1, knon
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C
+        IF (unstbl(i)) THEN
+          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+     .         *(1.+RETV*q(i,1))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+C
+C For all unstable layers, set diffusivities
+C
+        DO i = 1, knon
+        IF (unslev(i)) THEN
+            pcfm(i,k) = pblk(i)
+            pcfh(i,k) = pblk(i)/pr(i)
+        ENDIF
+        ENDDO
+ 1000 continue           ! end of level loop
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clouds_gno.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clouds_gno.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/clouds_gno.F	(revision 428)
@@ -0,0 +1,250 @@
+C
+C================================================================================
+C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+C     
+C--------------------------------------------------------------------------------
+C
+C Inputs:
+C
+C  ND----------: Number of vertical levels
+C  R--------ND-: Domain-averaged mixing ratio of total water 
+C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+C                with SUBGRID-SCALE condensation processes (here, it is
+C                predicted by the convection scheme)
+C Outputs:
+C
+C  PTCONV-----ND-: Point convectif = TRUE
+C  RATQSC-----ND-: Largeur normalisee de la distribution
+C  CLDF-----ND-: Fraction nuageuse
+C
+C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+c -- parameters controlling the iteration:
+c --    nmax    : maximum nb of iterations (hopefully never reached)
+c --    epsilon : accuracy of the numerical resolution 
+c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+     
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat(klon), delta(klon), beta(klon) 
+      real zu2(klon),zv2(klon)
+      REAL xx(klon), aux(klon), coeff(klon), block(klon)
+      REAL  dist(klon), fprime(klon), det(klon)
+      REAL pi, u(klon), v(klon), erfu(klon), erfv(klon)
+      REAL  xx1(klon), xx2(klon)
+      real erf,kkk
+c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+
+      pi = ACOS(-1.)
+
+      ptconv=.false.
+      ratqsc=0.
+
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat(i) = RS(i,K) 
+      qsat(i) = MAX(qsat(i),min_mu)
+      delta(i) = log(mu(i)/qsat(i))
+                                    enddo ! vector
+
+C
+C ***          There is no subgrid-scale condensation;        ***
+C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+C ***             large-scale condensation scheme.            ***
+C
+
+C
+C ***     Some condensation is produced at the subgrid-scale       ***
+C ***                                                              ***
+C ***       PDF = generalized log-normal distribution (GNO)        ***
+C ***   (k<0 because a lower bound is considered for the PDF)      ***
+C ***                                                              ***
+C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+C ***  that the contribution of subgrid-scale processes to         ***
+C ***  the in-cloud water content is equal to QSUB(K)              ***
+C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+C ***                                                              ***
+C ***    Here, an iterative method is used for this purpose        ***
+C ***    (other numerical methods might be more efficient)         ***
+C ***                                                              ***
+C ***          NB: the "error function" is called ERF              ***
+C ***                 (ERF in double precision)                   ***
+C
+
+c  On commence par eliminer les cas pour lesquels on n'a pas
+c  suffisamment d'eau nuageuse.
+
+                                    do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+c --  roots of equation v > vmax:
+
+        det(i) = delta(i) + vmax(i)**2.
+        if (det(i).LE.0.0) vmax(i) = vmax0 + 1.0
+        det(i) = delta(i) + vmax(i)**2.
+
+        if (det(i).LE.0.) then
+          xx(i) = -0.0001
+        else 
+         xx1(i)=-SQRT(2.)*vmax(i)*(1.0-SQRT(1.0+delta(i)/(vmax(i)**2.)))
+         xx2(i)=-SQRT(2.)*vmax(i)*(1.0+SQRT(1.0+delta(i)/(vmax(i)**2.)))
+         xx(i) = 1.01 * xx1(i)
+         if ( xx1(i) .GE. 0.0 ) xx(i) = 0.5*xx2(i)
+        endif
+        if (delta(i).LT.0.) xx(i) = -0.5*SQRT(log(2.)) 
+
+      ENDIF
+
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Debut des nmax iterations pour trouver la solution.
+c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u(i) = delta(i)/(xx(i)*sqrt(2.)) + xx(i)/(2.*sqrt(2.))
+          v(i) = delta(i)/(xx(i)*sqrt(2.)) - xx(i)/(2.*sqrt(2.))
+
+          IF ( v(i) .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u(i))  .GT. vmax(i) 
+     :          .AND.  delta(i) .LT. 0. ) THEN
+
+c -- use asymptotic expression of erf for u and v large:
+c ( -> analytic solution for xx )
+
+             aux(i) = 2.0*delta(i)*(1.-beta(i)*EXP(delta(i)))
+     :                       /(1.+beta(i)*EXP(delta(i)))
+             if (aux(i).lt.0.) then
+                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block(i) = EXP(-v(i)*v(i)) / v(i) / SQRT(pi)
+             dist(i) = 0.0
+             fprime(i) = 1.0
+
+            ELSE
+
+c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfu(i) = ERF(u(i))
+c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = SQRT(pi)*(1.0-erfu(i))*EXP(min(v(i)*v(i),100.))
+             coeff(i) = 1.0 - 1./2./(v(i)**2.) + 3./4./(v(i)**4.)
+             block(i) = coeff(i) * EXP(-v(i)*v(i)) / v(i) / SQRT(pi)
+             dist(i) = v(i) * aux(i) / coeff(i) - beta(i)
+             fprime(i) = 2.0 / xx(i) * (v(i)**2.)
+     :           * ( coeff(i)*EXP(-delta(i)) - u(i) * aux(i) )
+     :           / coeff(i) / coeff(i)
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+c -- general case:
+
+           erfu(i) = ERF(u(i))
+           erfv(i) = ERF(v(i))
+           block(i) = 1.0-erfv(i)
+           dist(i) = (1.0 - erfu(i)) / (1.0 - erfv(i)) - beta(i)
+           zu2(i)=u(i)*u(i)
+           zv2(i)=v(i)*v(i)
+           if(zu2(i).gt.20..or. zv2(i).gt.20.) then
+              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+     .CLDF(i,k)
+              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2(i)=20.
+              zv2(i)=20.
+             fprime(i) = 0.
+           else
+             fprime(i) = 2. /SQRT(pi) /xx(i) /(1.0-erfv(i))**2.
+     :           * (   (1.0-erfv(i))*v(i)*EXP(-zu2(i))
+     :               - (1.0-erfu(i))*u(i)*EXP(-zv2(i)) )
+           endif
+          ENDIF ! x
+
+c -- test numerical convergence:
+
+c         print*,'avant test ',i,k,lconv(i),u(i),v(i)
+          if ( ABS(dist(i)/beta(i)) .LT. epsilon ) then 
+c           print*,'v-u **2',(v(i)-u(i))**2
+c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v(i)-u(i))**2,20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block(i)
+cccccccccccccccccccccccc
+c           kkk=-sqrt(log(1.+ratqsc(i,k)**2))
+c           u(i)=delta(i)/(kkk*sqrt(2.))-kkk/(2.*sqrt(2.))
+c           v(i)=delta(i)/(kkk*sqrt(2.))+kkk/(2.*sqrt(2.))
+c           erfu(i)=erf(u(i))
+c           erfv(i)=erf(v(i))
+c           print*,'SIG ',k,qsub(i,k)
+c    s      ,mu(i)*((1.-erfv(i))/(1.-erfu(i))-qsat(i)/mu(i))
+c    s      ,0.5*erfu(i)
+cccccccccccccccccccccccc
+          else
+            xx(i) = xx(i) - dist(i)/fprime(i)
+          endif
+c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END
+
+
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltrac.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltrac.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltrac.F	(revision 428)
@@ -0,0 +1,118 @@
+      SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp,
+     s                  d_tr)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+c            inspire de clvent
+c Objet: diffusion verticale de traceurs avec flux fixe a la surface
+c        ou/et flux du type c-drag
+c======================================================================
+c Arguments:
+c dtime----input-R- intervalle du temps (en second)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c tr-------input-R- la q. de traceurs
+c flux-----input-R- le flux de traceurs a la surface
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c cdrag----input-R- cdrag pour le flux de surface (non active)
+c tr0------input-R- traceurs a la surface ou dans l'ocean (non active)
+c d_tr-----output-R- le changement de tr
+c flux_tr--output-R- flux de tr
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+      REAL dtime
+      REAL coef(klon,klev)
+      REAL t(klon,klev), tr(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL d_tr(klon,klev)
+      REAL flux(klon), cdrag(klon), tr0(klon)
+c      REAL flux_tr(klon,klev)
+c======================================================================
+#include "YOMCST.h"
+c======================================================================
+      INTEGER i, k
+      REAL zx_ctr(klon,2:klev)
+      REAL zx_dtr(klon,2:klev)
+      REAL zx_buf(klon)
+      REAL zx_coef(klon,klev)
+      REAL local_tr(klon,klev)
+      REAL zx_alf1(klon), zx_alf2(klon), zx_flux(klon)
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+
+c======================================================================
+      DO i = 1, klon
+         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf2(i) = 1.0 - zx_alf1(i)
+         zx_flux(i) =  -flux(i)*dtime*RG
+c--pour le moment le flux est prescrit
+c--cdrag et zx_coef(1) vaut 0
+         cdrag(i) = 0.0 
+         tr0(i) = 0.0
+         zx_coef(i,1) = cdrag(i)*dtime*RG 
+      ENDDO
+c======================================================================
+      DO k = 2, klev
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k)*dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+         zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+
+     .                  zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+         zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) / 
+     .                  zx_buf(i)
+      ENDDO
+c
+      DO k = 3, klev
+      DO i = 1, klon
+         zx_buf(i) = delp(i,k-1) + zx_coef(i,k)
+     .                  + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+         zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)
+     .                  +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+         zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev)
+     .                        +zx_coef(i,klev)*zx_ctr(i,klev) )
+     .                   / ( delp(i,klev) + zx_coef(i,klev)
+     .                       -zx_coef(i,klev)*zx_dtr(i,klev) )
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== flux_tr est le flux de traceur (positif vers bas)
+c      DO i = 1, klon
+c         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+c     .               * (local_tr(i,k)-local_tr(i,k-1))
+c      ENDDO
+c      ENDDO
+c======================================================================
+      DO k = 1, klev
+      DO i = 1, klon
+         d_tr(i,k) = local_tr(i,k) - tr(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltracrn.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltracrn.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cltracrn.F	(revision 428)
@@ -0,0 +1,290 @@
+      SUBROUTINE cltracrn( itr, dtime,u1lay, v1lay,
+     e              coef,t,ftsol,pctsrf,
+     e              tr,trs,paprs,pplay,delp,
+     e              masktr,fshtr,hsoltr,tautr,vdeptr,
+     e              lat,
+     s              d_tr,d_trs )
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Alex/LMD) date:  fev 99
+c            inspire de clqh + clvent
+c Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+c        le sol ( reservoir de sol de radon ) 
+c        
+c note : pour l'instant le traceur dans le sol et le flux sont
+c        calcules mais ils ne servent que de diagnostiques
+c        seule la tendance sur le traceur est sortie (d_tr)
+c======================================================================
+c Arguments:
+c itr---  -input-R- le type de traceur 1- Rn 2 - Pb
+c dtime----input-R- intervalle du temps (en second)
+c u1lay----input-R- vent u de la premiere couche (m/s)
+c v1lay----input-R- vent v de la premiere couche (m/s)
+c coef-----input-R- le coefficient d'echange (m**2/s) l>1
+c t--------input-R- temperature (K)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c delp-----input-R- epaisseur de couche (Pa)
+c ftsol----input-R- temperature du sol (en Kelvin)
+c tr-------input-R- traceurs
+c trs------input-R- traceurs dans le sol
+c masktr---input-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----input-R- Flux surfacique de production dans le sol
+c tautr----input-R- Constante de decroissance du traceur
+c vdeptr---input-R- Vitesse de depot sec dans la couche brownienne
+c hsoltr---input-R- Epaisseur equivalente du reservoir de sol
+c lat-----input-R- latitude en degree
+c d_tr-----output-R- le changement de "tr"
+c d_trs----output-R- le changement de "trs"
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c======================================================================
+      REAL dtime
+      REAL u1lay(klon), v1lay(klon)
+      REAL coef(klon,klev)
+      REAL t(klon,klev), ftsol(klon,nbsrf), pctsrf(klon,nbsrf) 
+      REAL tr(klon,klev), trs(klon)
+      REAL paprs(klon,klev+1), pplay(klon,klev), delp(klon,klev)
+      REAL masktr(klon) 
+      REAL fshtr(klon) 
+      REAL hsoltr
+      REAL tautr
+      REAL vdeptr
+      REAL lat(klon)   
+      REAL d_tr(klon,klev)
+c======================================================================
+      REAL flux_tr(klon,klev)  ! (diagnostic) flux de traceur
+      REAL d_trs(klon)         ! (diagnostic) traceur ds le sol
+c======================================================================
+      INTEGER i, k, itr, n, l
+      REAL rotrhi(klon)
+      REAL zx_coef(klon,klev)
+      REAL zx_buf(klon)
+      REAL zx_ctr(klon,klev)
+      REAL zx_dtr(klon,klev)
+      REAL zx_trs(klon)
+      REAL zx_a, zx_b
+
+      REAL local_tr(klon,klev)
+      REAL local_trs(klon)
+      REAL zts(klon)
+      REAL zx_alpha1(klon), zx_alpha2(klon)
+c======================================================================
+cAA Pour l'instant les 4 types de surface ne sont pas pris en compte
+cAA On fabrique avec zts un champ de temperature de sol  
+cAA que le pondere par la fraction de nature de sol.
+c 
+      print*,'PASSAGE DANS CLTRACRN'
+
+      DO i = 1,klon
+            zts(i) = 0. 
+      ENDDO
+c
+      DO n=1,nbsrf
+         DO i = 1,klon
+            zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+         ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+          rotrhi(i) = RD * zts(i) / hsoltr 
+      END DO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         local_tr(i,k) = tr(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         local_trs(i) = trs(i)
+      ENDDO
+c======================================================================
+cAA   Attention si dans clmain zx_alf1(i) = 1.0 
+cAA   Il doit y avoir coherence (dc la meme chose ici)
+
+      DO i = 1, klon
+cAA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alpha1(i) = 1.0
+         zx_alpha2(i) = 1.0 - zx_alpha1(i)
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         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
+      DO i = 1, klon
+         zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))
+     .                  *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+         zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+      ENDDO
+      ENDDO
+c======================================================================
+      DO i = 1, klon
+         zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+         zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+         zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+      ENDDO
+c
+      DO l = klev-1, 2 , -1
+      DO i = 1, klon
+         zx_buf(i) = delp(i,l)+zx_coef(i,l)
+     .              +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+         zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l)
+     .                   + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+         zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))
+     .               + masktr(i) * zx_coef(i,1)
+     .               *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+         zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)
+     .                  + zx_ctr(i,2)
+     .                  *(zx_coef(i,2)
+     .                    - masktr(i) * zx_coef(i,1)
+     .                    *zx_alpha2(i) ) ) / zx_buf(i)
+         zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+      ENDDO
+c======================================================================
+c Calculer d'abord local_trs nouvelle quantite dans le reservoir
+c de sol
+c
+c-------------------------
+c Au dessus des continents
+c-------------------------
+c Le pb peut se deposer partout : vdeptr = 10-3 m/s
+c Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+c
+      DO i = 1, klon
+c
+        IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +fshtr(i)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+cAA: Pour l'instant, pour aller vite, le depot sec est traite
+C comme une decroissance
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c Si on est entre 60N et 70N on divise par 2 l'emanation
+c--------------------------------------------------------
+c
+        IF
+     .  ( (itr.eq.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.)
+     .                      .OR.
+     .     (itr.eq.2.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60.
+     .     .AND.lat(i).LE.70.) )
+     .  THEN
+         zx_trs(i) = local_trs(i)
+         zx_a = zx_trs(i)
+     .         +(fshtr(i)/2.)*dtime*rotrhi(i)
+     .         +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .         *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2))
+     .         +zx_alpha2(i)*zx_ctr(i,2))
+         zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG
+     .              * (1.-zx_dtr(i,1)
+     .              *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))
+     .              + dtime / tautr
+     .              + dtime * vdeptr / hsoltr
+         zx_trs(i) = zx_a / zx_b
+         local_trs(i) = zx_trs(i)
+        ENDIF
+c
+c----------------------------------------------
+c Au dessus des oceans et aux hautes latitudes
+c----------------------------------------------
+c
+c au dessous de -60S  pas d'emission de radon au dessus 
+c des oceans et des continents
+c---------------------------------------------------------------
+
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c au dessus de 70 N pas d'emission de radon au dessus 
+c des oceans et des continents
+c--------------------------------------------------------------
+       IF ( (itr.EQ.1.AND.NINT(masktr(i)).EQ.0)
+     .                 .OR.
+     . (itr.EQ.1.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.))
+     . THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+
+c Au dessus des oceans la source est nulle
+c-----------------------------------------
+c
+        IF (itr.eq.1.AND.NINT(masktr(i)).EQ.0) THEN
+         zx_trs(i) = 0.
+         local_trs(i) = 0.
+        END IF
+c
+      ENDDO    ! sur le i=1,klon
+c
+c======================================================================
+c==== une fois on a zx_trs, on peut faire l'iteration ========
+c
+      DO i = 1, klon
+         local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        local_tr(i,l)
+     .    = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+c
+      DO i = 1, klon
+        flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG
+     .      * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2)
+     .                   -zx_trs(i)) / dtime
+      ENDDO
+      DO l = 2, klev
+      DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG
+     .       * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+      ENDDO
+      ENDDO
+c======================================================================
+c== Calcul des tendances du traceur ds le sol et dans l'atmosphere
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_tr(i,l) = local_tr(i,l) - tr(i,l)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         d_trs(i) = local_trs(i) - trs(i)
+      ENDDO
+c======================================================================
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/coefcdrag.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/coefcdrag.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/coefcdrag.F90	(revision 428)
@@ -0,0 +1,137 @@
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.inc
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+#include "YOMCST.inc"
+#include "YOETHF.inc"
+#include "indicesol.inc"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = speed(i)**2
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
+           zcfh1(i) = cdran(i) * frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
+           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conccm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conccm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conccm.F	(revision 428)
@@ -0,0 +1,830 @@
+      SUBROUTINE conccm (dtime,paprs,pplay,t,q,conv_q,
+     s                   d_t, d_q, rain, snow, kbascm, ktopcm)
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: le 14 mars 1996
+c Objet: Schema simple (avec flux de masse) pour la convection 
+c        (schema standard du modele NCAR CCM2)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Entree:
+      REAL dtime              ! pas d'integration
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (g/g)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c Sortie:
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation vapeur
+      REAL rain(klon)         ! pluie (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER kbascm(klon)    ! niveau du bas de convection
+      INTEGER ktopcm(klon)    ! niveau du haut de convection
+c
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pres(klon,klev)
+      REAL dp(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL cmfprs(klon)
+      REAL cmfprt(klon)
+      INTEGER ntop(klon)
+      INTEGER nbas(klon)
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql_bis(klon,klev)
+      REAL rneb_bis(klon,klev)
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kbascm(i) = 0
+         ktopcm(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         pres(i,k) = pplay(i,klev-k+1)
+         dp(i,k) = paprs(i,klev+1-k)-paprs(i,klev+1-k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                      * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgeom(i,klev+1-k) = zgeom(i,klev+1-k+1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+      CALL cmfmca(dtime, pres, dp, zgeom, pt, pq,
+     $                  cmfprt, cmfprs, ntop, nbas)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = pq(i,k) - q(i,klev+1-k) 
+         d_t(i,klev+1-k) = pt(i,k) - t(i,klev+1-k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         rain(i) = cmfprt(i) * rhoh2o
+         snow(i) = cmfprs(i) * rhoh2o
+         kbascm(i) = klev+1 - nbas(i)
+         ktopcm(i) = klev+1 - ntop(i)
+      ENDDO
+c
+      IF (usekuo) THEN
+      CALL conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s            d_t_bis, d_q_bis, d_ql_bis, rneb_bis,
+     s            rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         kbascm(i) = MIN(kbascm(i),ibas_bis(i))
+         ktopcm(i) = MAX(ktopcm(i),itop_bis(i))
+      ENDDO
+      DO k = 1, klev ! eau liquide convective est
+      DO i = 1, klon ! dispersee dans l'air
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql_bis(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE cmfmca(deltat, p, dp, gz,
+     $                  tb, shb,
+     $                  cmfprt, cmfprs, cnt, cnb)
+      IMPLICIT none
+C-----------------------------------------------------------------------
+C Moist convective mass flux procedure:
+C If stratification is unstable to nonentraining parcel ascent,
+C complete an adjustment making use of a simple cloud model
+C 
+C Code generalized to allow specification of parcel ("updraft")
+C properties, as well as convective transport of an arbitrary
+C number of passive constituents (see cmrb array).
+C----------------------------Code History-------------------------------
+C Original version:  J. J. Hack, March 22, 1990
+C Standardized:      J. Rosinski, June 1992
+C Reviewed:          J. Hack, G. Taylor, August 1992
+c Adaptation au LMD: Z.X. Li, mars 1996 (reference: Hack 1994,
+c                    J. Geophys. Res. vol 99, D3, 5551-5568). J'ai
+c                    introduit les constantes et les fonctions thermo-
+c                    dynamiques du Centre Europeen. J'ai elimine le
+c                    re-indicage du code en esperant que cela pourra
+c                    simplifier la lecture et la comprehension.
+C-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+      INTEGER pcnst ! nombre de traceurs passifs
+      PARAMETER (pcnst=1)
+C------------------------------Arguments--------------------------------
+C Input arguments
+C
+      REAL deltat                 ! time step (seconds)
+      REAL p(klon,klev)           ! pressure
+      REAL dp(klon,klev)          ! delta-p
+      REAL gz(klon,klev)          ! geopotential (a partir du sol)
+c
+      REAL thtap(klon)            ! PBL perturbation theta
+      REAL shp(klon)              ! PBL perturbation specific humidity 
+      REAL pblh(klon)             ! PBL height (provided by PBL routine)
+      REAL cmrp(klon,pcnst)       ! constituent perturbations in PBL
+c
+c Updated arguments:
+c
+      REAL tb(klon,klev)         ! temperature (t bar)
+      REAL shb(klon,klev)        ! specific humidity (sh bar)
+      REAL cmrb(klon,klev,pcnst) ! constituent mixing ratios (cmr bar)
+C
+C Output arguments
+C
+      REAL cmfdt(klon,klev)    ! dT/dt due to moist convection
+      REAL cmfdq(klon,klev)    ! dq/dt due to moist convection
+      REAL cmfmc(klon,klev )   ! moist convection cloud mass flux
+      REAL cmfdqr(klon,klev)   ! dq/dt due to convective rainout 
+      REAL cmfsl(klon,klev )   ! convective lw static energy flux
+      REAL cmflq(klon,klev )   ! convective total water flux
+      REAL cmfprt(klon)        ! convective precipitation rate
+      REAL cmfprs(klon)        ! convective snowfall rate
+      REAL qc(klon,klev)       ! dq/dt due to rainout terms
+      INTEGER cnt(klon)        ! top level of convective activity   
+      INTEGER cnb(klon)        ! bottom level of convective activity
+C------------------------------Parameters-------------------------------
+      REAL c0         ! rain water autoconversion coefficient
+      PARAMETER (c0=1.0e-4)
+      REAL dzmin       ! minimum convective depth for precipitation
+      PARAMETER (dzmin=0.0)
+      REAL betamn      ! minimum overshoot parameter
+      PARAMETER (betamn=0.10)
+      REAL cmftau      ! characteristic adjustment time scale
+      PARAMETER (cmftau=3600.)
+      INTEGER limcnv   ! top interface level limit for convection
+      PARAMETER (limcnv=1)
+      REAL tpmax       ! maximum acceptable t perturbation (degrees C)
+      PARAMETER (tpmax=1.50)
+      REAL shpmax      ! maximum acceptable q perturbation (g/g)
+      PARAMETER (shpmax=1.50e-3)
+      REAL tiny        ! arbitrary small num used in transport estimates
+      PARAMETER (tiny=1.0e-36)
+      REAL eps         ! convergence criteria (machine dependent)
+      PARAMETER (eps=1.0e-13)
+      REAL tmelt       ! freezing point of water(req'd for rain vs snow)
+      PARAMETER (tmelt=273.15)
+      REAL ssfac ! supersaturation bound (detrained air)
+      PARAMETER (ssfac=1.001)
+C
+C---------------------------Local workspace-----------------------------
+      REAL gam(klon,klev)     ! L/cp (d(qsat)/dT)
+      REAL sb(klon,klev)      ! dry static energy (s bar)
+      REAL hb(klon,klev)      ! moist static energy (h bar)
+      REAL shbs(klon,klev)    ! sat. specific humidity (sh bar star)
+      REAL hbs(klon,klev)     ! sat. moist static energy (h bar star)
+      REAL shbh(klon,klev+1)  ! specific humidity on interfaces
+      REAL sbh(klon,klev+1)   ! s bar on interfaces
+      REAL hbh(klon,klev+1)   ! h bar on interfaces
+      REAL cmrh(klon,klev+1)  ! interface constituent mixing ratio 
+      REAL prec(klon)         ! instantaneous total precipitation
+      REAL dzcld(klon)        ! depth of convective layer (m)
+      REAL beta(klon)         ! overshoot parameter (fraction)
+      REAL betamx             ! local maximum on overshoot
+      REAL eta(klon)          ! convective mass flux (kg/m^2 s)
+      REAL etagdt             ! eta*grav*deltat
+      REAL cldwtr(klon)       ! cloud water (mass)
+      REAL rnwtr(klon)        ! rain water  (mass)
+      REAL sc  (klon)         ! dry static energy   ("in-cloud")
+      REAL shc (klon)         ! specific humidity   ("in-cloud")
+      REAL hc  (klon)         ! moist static energy ("in-cloud")
+      REAL cmrc(klon)         ! constituent mix rat ("in-cloud")
+      REAL dq1(klon)          ! shb  convective change (lower lvl)
+      REAL dq2(klon)          ! shb  convective change (mid level)
+      REAL dq3(klon)          ! shb  convective change (upper lvl)
+      REAL ds1(klon)          ! sb   convective change (lower lvl)
+      REAL ds2(klon)          ! sb   convective change (mid level)
+      REAL ds3(klon)          ! sb   convective change (upper lvl)
+      REAL dcmr1(klon)        ! cmrb convective change (lower lvl)
+      REAL dcmr2(klon)        ! cmrb convective change (mid level)
+      REAL dcmr3(klon)        ! cmrb convective change (upper lvl)
+      REAL flotab(klon)       ! hc - hbs (mesure d'instabilite)
+      LOGICAL ldcum(klon)     ! .true. si la convection existe
+      LOGICAL etagt0          ! true if eta > 0.0
+      REAL dt                 ! current 2 delta-t (model time step)
+      REAL cats     ! modified characteristic adj. time
+      REAL rdt      ! 1./dt
+      REAL qprime   ! modified specific humidity pert.
+      REAL tprime   ! modified thermal perturbation
+      REAL pblhgt   ! bounded pbl height (max[pblh,1m])
+      REAL fac1     ! intermediate scratch variable
+      REAL shprme   ! intermediate specific humidity pert.
+      REAL qsattp   ! saturation mixing ratio for 
+C                   !  thermally perturbed PBL parcels 
+      REAL dz       ! local layer depth
+      REAL b1       ! bouyancy measure in detrainment lvl
+      REAL b2       ! bouyancy measure in condensation lvl
+      REAL g     ! bounded vertical gradient of hb
+      REAL tmass ! total mass available for convective exchange
+      REAL denom ! intermediate scratch variable
+      REAL qtest1! used in negative q test (middle lvl) 
+      REAL qtest2! used in negative q test (lower lvl) 
+      REAL fslkp ! flux lw static energy (bot interface)
+      REAL fslkm ! flux lw static energy (top interface)
+      REAL fqlkp ! flux total water (bottom interface)
+      REAL fqlkm ! flux total water (top interface)
+      REAL botflx! bottom constituent mixing ratio flux
+      REAL topflx! top constituent mixing ratio flux
+      REAL efac1 ! ratio cmrb to convectively induced change (bot lvl)
+      REAL efac2 ! ratio cmrb to convectively induced change (mid lvl)
+      REAL efac3 ! ratio cmrb to convectively induced change (top lvl)
+c
+      INTEGER i,k  ! indices horizontal et vertical
+      INTEGER km1  ! k-1 (index offset)
+      INTEGER kp1  ! k+1 (index offset)
+      INTEGER m    ! constituent index
+      INTEGER ktp  ! temporary index used to track top 
+      INTEGER is   ! nombre de points a ajuster
+C
+      REAL tmp1, tmp2, tmp3, tmp4
+      REAL zx_t, zx_p, zx_q, zx_qs, zx_gam
+      REAL zcor, zdelta, zcvm5
+C
+      REAL qhalf, sh1, sh2, shbs1, shbs2
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      qhalf(sh1,sh2,shbs1,shbs2) = MIN(MAX(sh1,sh2),
+     $                            (shbs2*sh1 + shbs1*sh2)/(shbs1+shbs2))
+C
+C-----------------------------------------------------------------------
+c pas de traceur pour l'instant
+      DO m = 1, pcnst
+      DO k = 1, klev
+      DO i = 1, klon
+         cmrb(i,k,m) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c Les perturbations de la couche limite sont zero pour l'instant
+c
+      DO m = 1, pcnst
+      DO i = 1, klon
+         cmrp(i,m) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         thtap(i) = 0.0
+         shp(i) = 0.0
+         pblh(i) = 1.0
+      ENDDO
+C
+C Ensure that characteristic adjustment time scale (cmftau) assumed
+C in estimate of eta isn't smaller than model time scale (deltat)
+C
+      dt   = deltat
+      cats = MAX(dt,cmftau)
+      rdt  = 1.0/dt
+C
+C Compute sb,hb,shbs,hbs
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = tb(i,k)
+         zx_p = p(i,k)
+         zx_q = shb(i,k)
+           zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+           zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+           zx_qs=MIN(0.5,zx_qs)
+           zcor=1./(1.-retv*zx_qs)
+           zx_qs=zx_qs*zcor
+           zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+         shbs(i,k) = zx_qs
+         gam(i,k) = zx_gam
+      ENDDO
+      ENDDO
+C
+      DO k=limcnv,klev
+         DO i=1,klon
+            sb (i,k) = RCPD*tb(i,k) + gz(i,k)
+            hb (i,k) = sb(i,k) + RLVTT*shb(i,k)
+            hbs(i,k) = sb(i,k) + RLVTT*shbs(i,k)
+         ENDDO
+      ENDDO
+C
+C Compute sbh, shbh
+C
+      DO k=limcnv+1,klev
+         km1 = k - 1
+         DO i=1,klon
+            sbh (i,k) =0.5*(sb(i,km1) + sb(i,k))
+            shbh(i,k) =qhalf(shb(i,km1),shb(i,k),shbs(i,km1),shbs(i,k))
+            hbh (i,k) =sbh(i,k) + RLVTT*shbh(i,k)
+         ENDDO
+      ENDDO
+C
+C Specify properties at top of model (not used, but filling anyway)
+C
+      DO i=1,klon
+         sbh (i,limcnv) = sb(i,limcnv)
+         shbh(i,limcnv) = shb(i,limcnv)
+         hbh (i,limcnv) = hb(i,limcnv)
+      ENDDO
+C
+C Zero vertically independent control, tendency & diagnostic arrays
+C
+      DO i=1,klon
+         prec(i)  = 0.0
+         dzcld(i) = 0.0
+         cnb(i)   = 0
+         cnt(i)   = klev+1
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1,klon
+         cmfdt(i,k)  = 0.
+         cmfdq(i,k)  = 0.
+         cmfdqr(i,k) = 0.
+         cmfmc(i,k)  = 0.
+         cmfsl(i,k)  = 0.
+         cmflq(i,k)  = 0.
+        ENDDO
+      ENDDO
+C
+C Begin moist convective mass flux adjustment procedure.
+C Formalism ensures that negative cloud liquid water can never occur
+C
+      DO 70 k=klev-1,limcnv+1,-1
+         km1 = k - 1
+         kp1 = k + 1
+         DO 10 i=1,klon
+            eta   (i) = 0.0
+            beta  (i) = 0.0
+            ds1   (i) = 0.0
+            ds2   (i) = 0.0
+            ds3   (i) = 0.0
+            dq1   (i) = 0.0
+            dq2   (i) = 0.0
+            dq3   (i) = 0.0
+C
+C Specification of "cloud base" conditions
+C
+            qprime    = 0.0
+            tprime    = 0.0
+C
+C Assign tprime within the PBL to be proportional to the quantity
+C thtap (which will be bounded by tpmax), passed to this routine by 
+C the PBL routine.  Don't allow perturbation to produce a dry 
+C adiabatically unstable parcel.  Assign qprime within the PBL to be 
+C an appropriately modified value of the quantity shp (which will be 
+C bounded by shpmax) passed to this routine by the PBL routine.  The 
+C quantity qprime should be less than the local saturation value 
+C (qsattp=qsat[t+tprime,p]).  In both cases, thtap and shp are
+C linearly reduced toward zero as the PBL top is approached.
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.0) THEN
+               fac1   = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               tprime = MIN(thtap(i),tpmax)*fac1
+               qsattp = shbs(i,kp1) + RCPD/RLVTT*gam(i,kp1)*tprime
+               shprme = MIN(MIN(shp(i),shpmax)*fac1,
+     $                        MAX(qsattp-shb(i,kp1),0.0))
+               qprime = MAX(qprime,shprme)
+            ELSE
+               tprime = 0.0
+               qprime = 0.0
+            ENDIF
+C
+C Specify "updraft" (in-cloud) thermodynamic properties
+C
+            sc (i)    = sb (i,kp1) + RCPD*tprime
+            shc(i)    = shb(i,kp1) + qprime
+            hc (i)    = sc (i    ) + RLVTT*shc(i)
+            flotab(i) = hc(i) - hbs(i,k)
+            dz        = dp(i,k)*RD*tb(i,k)/RG/p(i,k)
+            IF (flotab(i).gt.0.0) THEN
+               dzcld(i) = dzcld(i) + dz
+            ELSE
+               dzcld(i) = 0.0
+            ENDIF
+   10    CONTINUE
+C
+C Check on moist convective instability
+C
+         is = 0
+         DO i = 1, klon
+            IF (flotab(i).GT.0.0) THEN
+               ldcum(i) = .TRUE.
+               is = is + 1
+            ELSE
+               ldcum(i) = .FALSE.
+            ENDIF
+         ENDDO
+C
+         IF (is.EQ.0) THEN
+            DO i=1,klon
+               dzcld(i) = 0.0
+            ENDDO
+            GOTO 70
+         ENDIF
+C
+C Current level just below top level => no overshoot
+C
+         IF (k.le.limcnv+1) THEN
+            DO i=1,klon
+            IF (ldcum(i)) THEN
+               cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+               cldwtr(i) = MAX(0.0,cldwtr(i))
+               beta(i)   = 0.0
+            ENDIF
+            ENDDO
+            GOTO 20
+         ENDIF
+C
+C First guess at overshoot parameter using crude buoyancy closure
+C 10% overshoot assumed as a minimum and 1-c0*dz maximum to start
+C If pre-existing supersaturation in detrainment layer, beta=0
+C cldwtr is temporarily equal to RLVTT*l (l=> liquid water)
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            cldwtr(i) = sb(i,k)-sc(i)+flotab(i)/(1.0+gam(i,k))
+            cldwtr(i) = MAX(0.0,cldwtr(i))
+            betamx = 1.0 - c0*MAX(0.0,(dzcld(i)-dzmin))
+            b1        = (hc(i) - hbs(i,km1))*dp(i,km1)
+            b2        = (hc(i) - hbs(i,k  ))*dp(i,k  )
+            beta(i)   = MAX(betamn,MIN(betamx, 1.0+b1/b2))
+            IF (hbs(i,km1).le.hb(i,km1)) beta(i) = 0.0
+         ENDIF
+         ENDDO
+C
+C Bound maximum beta to ensure physically realistic solutions
+C
+C First check constrains beta so that eta remains positive
+C (assuming that eta is already positive for beta equal zero)
+c La premiere contrainte de beta est que le flux eta doit etre positif.
+C
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp2 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.99*(tmp1/tmp2)
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+C
+C Second check involves supersaturation of "detrainment layer"
+C small amount of supersaturation acceptable (by ssfac factor)
+c La 2e contrainte est que la convection ne doit pas sursaturer
+c la "detrainment layer", Neanmoins, une petite sursaturation
+c est acceptee (facteur ssfac).
+C
+            IF (hb(i,km1).lt.hbs(i,km1)) THEN
+               tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $               - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+               tmp1 = tmp1/dp(i,k)
+               tmp2 = gam(i,km1)*(sbh(i,k)-sc(i) + cldwtr(i)) -
+     $                 hbh(i,k) + hc(i) - sc(i) + sbh(i,k)
+               tmp3 = (1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+               tmp4 = (dt/cats)*(hc(i)-hbs(i,k))*tmp2
+     $               / (dp(i,km1)*(hbs(i,km1)-hb(i,km1))) + tmp3
+               IF ((beta(i)*tmp4-tmp1).GT.0.0) THEN
+                  betamx = ssfac*(tmp1/tmp4)
+                  beta(i)   = MAX(0.0,MIN(betamx,beta(i)))
+               ENDIF
+            ELSE 
+               beta(i) = 0.0
+            ENDIF
+C
+C Third check to avoid introducing 2 delta x thermodynamic
+C noise in the vertical ... constrain adjusted h (or theta e)
+C so that the adjustment doesn't contribute to "kinks" in h
+C
+            g = MIN(0.0,hb(i,k)-hb(i,km1))
+            tmp3 = (hb(i,k)-hb(i,km1)-g)*(cats/dt) / (hc(i)-hbs(i,k))
+            tmp1 = (1.0+gam(i,k))*(sc(i)-sbh(i,kp1) + cldwtr(i))
+     $            - (hbh(i,kp1)-hc(i))*dp(i,k)/dp(i,kp1)
+            tmp1 = tmp1/dp(i,k)
+            tmp1 = tmp3*tmp1 + (hc(i) - hbh(i,kp1))/dp(i,k)
+            tmp2 = tmp3*(1.0+gam(i,k))*(sc(i)-sbh(i,k))/dp(i,k)
+     $            + (hc(i)-hbh(i,k)-cldwtr(i))
+     $             *(1.0/dp(i,k)+1.0/dp(i,kp1))
+            IF ((beta(i)*tmp2-tmp1).GT.0.0) THEN
+               betamx = 0.0
+               IF (tmp2.NE.0.0) betamx = tmp1/tmp2
+               beta(i) = MAX(0.0,MIN(betamx,beta(i)))
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C Calculate mass flux required for stabilization.
+C
+C Ensure that the convective mass flux, eta, is positive by
+C setting negative values of eta to zero..
+C Ensure that estimated mass flux cannot move more than the
+C minimum of total mass contained in either layer k or layer k+1.
+C Also test for other pathological cases that result in non-
+C physical states and adjust eta accordingly.
+C
+   20    CONTINUE
+         DO i=1,klon
+         IF (ldcum(i)) THEN
+            beta(i) = MAX(0.0,beta(i))
+            tmp1 = hc(i) - hbs(i,k)
+            tmp2 = ((1.0+gam(i,k))*(sc(i)-sbh(i,kp1)+cldwtr(i)) -
+     $               beta(i)*(1.0+gam(i,k))*(sc(i)-sbh(i,k)))/dp(i,k) -
+     $              (hbh(i,kp1)-hc(i))/dp(i,kp1)
+            eta(i) = tmp1/(tmp2*RG*cats)
+            tmass = MIN(dp(i,k),dp(i,kp1))/RG
+            IF (eta(i).GT.tmass*rdt .OR. eta(i).LE.0.0) eta(i) = 0.0
+C
+C Check on negative q in top layer (bound beta)
+C
+            IF(shc(i)-shbh(i,k).LT.0.0 .AND. beta(i)*eta(i).NE.0.0)THEN
+               denom = eta(i)*RG*dt*(shc(i) - shbh(i,k))/dp(i,km1)
+               beta(i) = MAX(0.0,MIN(-0.999*shb(i,km1)/denom,beta(i)))
+            ENDIF
+C
+C Check on negative q in middle layer (zero eta)
+C
+            qtest1 = shb(i,k) + eta(i)*RG*dt*((shc(i) - shbh(i,kp1)) -
+     $               (1.0 - beta(i))*cldwtr(i)/RLVTT -
+     $               beta(i)*(shc(i) - shbh(i,k)))/dp(i,k)
+            IF (qtest1.le.0.0) eta(i) = 0.0
+C
+C Check on negative q in lower layer (bound eta)
+C
+            fac1 = -(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            qtest2 = shb(i,kp1) - eta(i)*RG*dt*fac1
+            IF (qtest2 .lt. 0.0) THEN
+               eta(i) = 0.99*shb(i,kp1)/(RG*dt*fac1)
+            ENDIF
+         ENDIF
+         ENDDO
+C
+C
+C Calculate cloud water, rain water, and thermodynamic changes
+C
+         DO 30 i=1,klon
+         IF (ldcum(i)) THEN
+            etagdt = eta(i)*RG*dt
+            cldwtr(i) = etagdt*cldwtr(i)/RLVTT/RG
+            rnwtr(i) = (1.0 - beta(i))*cldwtr(i)
+            ds1(i) = etagdt*(sbh(i,kp1) - sc(i))/dp(i,kp1)
+            dq1(i) = etagdt*(shbh(i,kp1) - shc(i))/dp(i,kp1)
+            ds2(i) = (etagdt*(sc(i) - sbh(i,kp1)) +
+     $                RLVTT*RG*cldwtr(i) - beta(i)*etagdt*
+     $                (sc(i) - sbh(i,k)))/dp(i,k)
+            dq2(i) = (etagdt*(shc(i) - shbh(i,kp1)) -
+     $                RG*rnwtr(i) - beta(i)*etagdt*
+     $                (shc(i) - shbh(i,k)))/dp(i,k)
+            ds3(i) = beta(i)*(etagdt*(sc(i) - sbh(i,k)) -
+     $               RLVTT*RG*cldwtr(i))/dp(i,km1)
+            dq3(i) = beta(i)*etagdt*(shc(i) - shbh(i,k))/dp(i,km1)
+C
+C Isolate convective fluxes for later diagnostics
+C
+            fslkp = eta(i)*(sc(i) - sbh(i,kp1))
+            fslkm = beta(i)*(eta(i)*(sc(i) - sbh(i,k)) -
+     $                       RLVTT*cldwtr(i)*rdt)
+            fqlkp = eta(i)*(shc(i) - shbh(i,kp1))
+            fqlkm = beta(i)*eta(i)*(shc(i) - shbh(i,k))
+C
+C
+C Update thermodynamic profile (update sb, hb, & hbs later)
+C
+            tb (i,kp1) = tb(i,kp1)  + ds1(i) / RCPD
+            tb (i,k  ) = tb(i,k  )  + ds2(i) / RCPD
+            tb (i,km1) = tb(i,km1)  + ds3(i) / RCPD
+            shb(i,kp1) = shb(i,kp1) + dq1(i)
+            shb(i,k  ) = shb(i,k  ) + dq2(i)
+            shb(i,km1) = shb(i,km1) + dq3(i)
+            prec(i)    = prec(i)    + rnwtr(i)/rhoh2o
+C
+C Update diagnostic information for final budget
+C Tracking temperature & specific humidity tendencies,
+C rainout term, convective mass flux, convective liquid
+C water static energy flux, and convective total water flux
+C
+            cmfdt (i,kp1) = cmfdt (i,kp1) + ds1(i)/RCPD*rdt
+            cmfdt (i,k  ) = cmfdt (i,k  ) + ds2(i)/RCPD*rdt
+            cmfdt (i,km1) = cmfdt (i,km1) + ds3(i)/RCPD*rdt
+            cmfdq (i,kp1) = cmfdq (i,kp1) + dq1(i)*rdt
+            cmfdq (i,k  ) = cmfdq (i,k  ) + dq2(i)*rdt
+            cmfdq (i,km1) = cmfdq (i,km1) + dq3(i)*rdt
+            cmfdqr(i,k  ) = cmfdqr(i,k  ) + (RG*rnwtr(i)/dp(i,k))*rdt
+            cmfmc (i,kp1) = cmfmc (i,kp1) + eta(i)
+            cmfmc (i,k  ) = cmfmc (i,k  ) + beta(i)*eta(i)
+            cmfsl (i,kp1) = cmfsl (i,kp1) + fslkp
+            cmfsl (i,k  ) = cmfsl (i,k  ) + fslkm
+            cmflq (i,kp1) = cmflq (i,kp1) + RLVTT*fqlkp
+            cmflq (i,k  ) = cmflq (i,k  ) + RLVTT*fqlkm
+            qc    (i,k  ) =                (RG*rnwtr(i)/dp(i,k))*rdt
+         ENDIF
+   30    CONTINUE
+C
+C Next, convectively modify passive constituents
+C
+         DO 50 m=1,pcnst
+         DO 40 i=1,klon
+         IF (ldcum(i)) THEN
+C
+C If any of the reported values of the constituent is negative in
+C the three adjacent levels, nothing will be done to the profile
+C
+            IF ((cmrb(i,kp1,m).LT.0.0) .OR.
+     $          (cmrb(i,k,m).LT.0.0) .OR.
+     $          (cmrb(i,km1,m).LT.0.0)) GOTO 40
+C
+C Specify constituent interface values (linear interpolation)
+C
+            cmrh(i,k  ) = 0.5*(cmrb(i,km1,m) + cmrb(i,k  ,m))
+            cmrh(i,kp1) = 0.5*(cmrb(i,k  ,m) + cmrb(i,kp1,m))
+C
+C Specify perturbation properties of constituents in PBL
+C
+            pblhgt = MAX(pblh(i),1.0)
+            IF (gz(i,kp1)/RG.LE.pblhgt .AND. dzcld(i).EQ.0.) THEN
+               fac1 = MAX(0.0,1.0-gz(i,kp1)/RG/pblhgt)
+               cmrc(i) = cmrb(i,kp1,m) + cmrp(i,m)*fac1
+            ELSE
+               cmrc(i) = cmrb(i,kp1,m)
+            ENDIF
+C
+C Determine fluxes, flux divergence => changes due to convection
+C Logic must be included to avoid producing negative values. A bit
+C messy since there are no a priori assumptions about profiles.
+C Tendency is modified (reduced) when pending disaster detected.
+C
+            etagdt = eta(i)*RG*dt
+            botflx   = etagdt*(cmrc(i) - cmrh(i,kp1))
+            topflx   = beta(i)*etagdt*(cmrc(i)-cmrh(i,k))
+            dcmr1(i) = -botflx/dp(i,kp1)
+            efac1    = 1.0
+            efac2    = 1.0
+            efac3    = 1.0
+C
+            IF (cmrb(i,kp1,m)+dcmr1(i) .LT. 0.0) THEN
+               efac1 = MAX(tiny,ABS(cmrb(i,kp1,m)/dcmr1(i)) - eps)
+            ENDIF
+C
+            IF (efac1.EQ.tiny .OR. efac1.GT.1.0) efac1 = 0.0
+            dcmr1(i) = -efac1*botflx/dp(i,kp1)
+            dcmr2(i) = (efac1*botflx - topflx)/dp(i,k)
+C  
+            IF (cmrb(i,k,m)+dcmr2(i) .LT. 0.0) THEN
+               efac2 = MAX(tiny,ABS(cmrb(i,k  ,m)/dcmr2(i)) - eps)
+            ENDIF
+C
+            IF (efac2.EQ.tiny .OR. efac2.GT.1.0) efac2 = 0.0
+            dcmr2(i) = (efac1*botflx - efac2*topflx)/dp(i,k)
+            dcmr3(i) = efac2*topflx/dp(i,km1)
+C
+            IF (cmrb(i,km1,m)+dcmr3(i) .LT. 0.0) THEN
+               efac3 = MAX(tiny,ABS(cmrb(i,km1,m)/dcmr3(i)) - eps)
+            ENDIF
+C
+            IF (efac3.EQ.tiny .OR. efac3.GT.1.0) efac3 = 0.0
+            efac3    = MIN(efac2,efac3)
+            dcmr2(i) = (efac1*botflx - efac3*topflx)/dp(i,k)
+            dcmr3(i) = efac3*topflx/dp(i,km1)
+C
+            cmrb(i,kp1,m) = cmrb(i,kp1,m) + dcmr1(i)
+            cmrb(i,k  ,m) = cmrb(i,k  ,m) + dcmr2(i)
+            cmrb(i,km1,m) = cmrb(i,km1,m) + dcmr3(i)
+         ENDIF
+   40    CONTINUE
+   50    CONTINUE              ! end of m=1,pcnst loop
+C
+         IF (k.EQ.limcnv+1) GOTO 60 ! on ne pourra plus glisser
+c
+c Dans la procedure de glissage ascendant, les variables thermo-
+c dynamiques des couches k et km1 servent au calcul des couches
+c superieures. Elles ont donc besoin d'une mise-a-jour.
+C
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            zx_t = tb(i,k)
+            zx_p = p(i,k)
+            zx_q = shb(i,k)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,k) = zx_qs
+            gam(i,k) = zx_gam
+c
+            zx_t = tb(i,km1)
+            zx_p = p(i,km1)
+            zx_q = shb(i,km1)
+              zdelta=MAX(0.,SIGN(1.,RTT-zx_t))
+              zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+              zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*zx_q)
+              zx_qs= r2es * FOEEW(zx_t,zdelta)/zx_p
+              zx_qs=MIN(0.5,zx_qs)
+              zcor=1./(1.-retv*zx_qs)
+              zx_qs=zx_qs*zcor
+              zx_gam = FOEDE(zx_t,zdelta,zcvm5,zx_qs,zcor)
+            shbs(i,km1) = zx_qs
+            gam(i,km1) = zx_gam
+C
+            sb (i,k  ) = sb(i,k  ) + ds2(i)
+            sb (i,km1) = sb(i,km1) + ds3(i)
+            hb (i,k  ) = sb(i,k  ) + RLVTT*shb(i,k)
+            hb (i,km1) = sb(i,km1) + RLVTT*shb(i,km1)
+            hbs(i,k  ) = sb(i,k  ) + RLVTT*shbs(i,k  )
+            hbs(i,km1) = sb(i,km1) + RLVTT*shbs(i,km1)
+C
+            sbh (i,k) = 0.5*(sb(i,k) + sb(i,km1))
+            shbh(i,k) = qhalf(shb(i,km1),shb(i,k)
+     $                       ,shbs(i,km1),shbs(i,k))
+            hbh (i,k) = sbh(i,k) + RLVTT*shbh(i,k)
+            sbh (i,km1) = 0.5*(sb(i,km1) + sb(i,k-2))
+            shbh(i,km1) = qhalf(shb(i,k-2),shb(i,km1),
+     $                    shbs(i,k-2),shbs(i,km1))
+            hbh (i,km1) = sbh(i,km1) + RLVTT*shbh(i,km1)
+         ENDIF
+         ENDDO
+C
+C Ensure that dzcld is reset if convective mass flux zero
+C specify the current vertical extent of the convective activity
+C top of convective layer determined by size of overshoot param.
+C
+   60    CONTINUE
+         DO i=1,klon
+            etagt0 = eta(i).gt.0.0
+            IF (.not.etagt0) dzcld(i) = 0.0
+            IF (etagt0 .and. beta(i).gt.betamn) THEN
+               ktp = km1
+            ELSE
+               ktp = k
+            ENDIF
+            IF (etagt0) THEN
+               cnt(i) = MIN(cnt(i),ktp)
+               cnb(i) = MAX(cnb(i),k)
+            ENDIF
+         ENDDO
+   70 CONTINUE        ! end of k loop
+C
+C determine whether precipitation, prec, is frozen (snow) or not
+C
+      DO i=1,klon
+         IF (tb(i,klev).LT.tmelt .AND. tb(i,klev-1).lt.tmelt) THEN
+             cmfprs(i) = prec(i)*rdt
+         ELSE
+             cmfprt(i) = prec(i)*rdt
+         ENDIF
+      ENDDO
+C
+      RETURN  ! we're all done ... return to calling procedure
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/concvl.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/concvl.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/concvl.F	(revision 428)
@@ -0,0 +1,173 @@
+      SUBROUTINE concvl (iflag_con,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,
+     .             qcondc,wd)
+ 
+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
+       INTEGER iflag_con
+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)
+       REAL qcondc(klon,klev)
+       REAL wd(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
+      if (iflag_con .eq. 4) then
+      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
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+c
+C------------------------------------------------------------------
+
+C Main driver for convection:
+C		iflag_con = 3  -> equivalent to convect3
+C		iflag_con = 4  -> equivalent to convect1/2
+
+      CALL cv_driver(klon,klev,klev+1,ntra,iflag_con,
+     :              t,q,qs,u,v,tra,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,d_tra,rain,
+     $              cbmf,work1,work2,
+     $              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape)
+
+C------------------------------------------------------------------
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      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
+      ENDDO
+ 
+c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+ 
+      RETURN
+      END
+ 
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/condsurf.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/condsurf.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/condsurf.F	(revision 428)
@@ -0,0 +1,319 @@
+c $Header$
+c
+      SUBROUTINE condsurf( jour, jourvrai, pctsrf,
+     s                    lmt_sst,lmt_alb,lmt_rug,lmt_bils )
+      IMPLICIT none
+c
+c Lire les conditions aux limites du modele.
+c -----------------------------------------
+c jour     : input  , numero du jour a lire
+c jourvrai : input  , vrai jour de la simulation  
+c
+c pctsrf:  sous-maille fractionnelle, la somme doit = 1
+c lmt_sst: temperature de la surface oceanique
+c lmt_alb: albedo du sol
+c lmt_rug: longeur de rugosite du sol
+c lmt_bils: bilan chaleur au sol (a utiliser pour "slab-ocean")
+c
+#include "netcdf.inc"
+      INTEGER nid, nvarid
+      INTEGER debut(2)
+      INTEGER epais(2)
+      INTEGER lnblnk
+      EXTERNAL lnblnk
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "indicesol.h"
+#include "temps.h"
+#include "clesphys.h"
+c
+c newlmt indique l'utilisation de la sous-maille fractionnelle,
+c tandis que l'ancien regime utilisait l'indicateur du sol (0,1,2,3).
+
+      LOGICAL newlmt
+      PARAMETER (newlmt=.TRUE.)
+
+      INTEGER     nannemax
+      PARAMETER ( nannemax = 60 )
+c
+      INTEGER jour,jourvrai
+      REAL lmt_nat(klon) ! indicateur de la nature du sol
+      REAL pctsrf(klon,nbsrf) ! sous-maille fractionnelle
+      REAL lmt_sst(klon) ! temperature de la surface oceanique
+      REAL lmt_alb(klon) ! albedo du sol
+      REAL lmt_rug(klon) ! longeur de rugosite du sol
+      REAL lmt_bils(klon)
+c
+c Variables locales:
+      INTEGER ig, i, j, kt, ierr
+      LOGICAL ok
+      INTEGER anneelim,anneemax
+      CHARACTER*20 fich
+cc
+cc   .....................................................................
+cc
+cc    Pour lire le fichier limit correspondant vraiment  a l'annee de la
+cc     simulation en cours , il suffit de mettre  ok_limitvrai = .TRUE.
+cc
+cc   ......................................................................
+c
+c
+      IF (jour.LT.0 .OR. jour.GT.(360-1)) THEN
+         PRINT*,'Le jour demande n est pas correct: ', jour
+         CALL ABORT
+      ENDIF
+c
+c  .............   modif  (  P. Le Van )  ...........
+
+       anneelim  = annee_ref
+       anneemax  = annee_ref + nannemax
+c
+c
+       IF( ok_limitvrai )       THEN
+          DO  kt = 1, nannemax
+            IF(jourvrai.LE. (kt-1)*360 + 359  )  THEN
+              WRITE(fich,'("limit",i4,".nc")') anneelim
+              PRINT *,' Fichier  Limite ',fich
+              GO TO 100
+             ENDIF
+           anneelim = anneelim + 1
+          ENDDO
+
+         PRINT *,' PBS ! Le jour a lire sur le fichier limit ne se '
+         PRINT *,' trouve pas sur les ',nannemax,' annees a partir de '
+         PRINT *,' l annee de debut', annee_ref
+           CALL EXIT(1)
+c
+100     CONTINUE
+c
+       ELSE
+     
+            WRITE(fich,'("limit.nc")') 
+            PRINT *,' Fichier  Limite ',fich
+       ENDIF
+c
+c  ........... ( fin   modif   P. Le Van  ) ............
+c
+c Ouvrir le fichier en format NetCDF:
+c
+      ierr = NF_OPEN (fich, NF_NOWRITE,nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Pb d''ouverture du fichier ', fich
+        WRITE(6,*)' Le fichier limit ',fich,' (avec 4 chiffres , pour' 
+        WRITE(6,*)'       l an 2000 )  ,  n existe  pas !  ' 
+        WRITE(6,*)' ierr = ', ierr
+        CALL EXIT(1)
+      ENDIF
+c
+c La tranche de donnees a lire:
+c
+      debut(1) = 1
+      debut(2) = jour + 1
+      epais(1) = klon
+      epais(2) = 1
+c
+      IF (newlmt) THEN
+c
+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
+         PRINT*, "condsurf: Le champ <FSIC> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_sic))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_sic))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <FSIC>"
+         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
+c
+c Indicateur de la nature du sol (0,1,2,3):
+      ierr = NF_INQ_VARID (nid, "NAT", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <NAT> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_nat)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_nat)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <NAT>"
+         CALL abort
+      ENDIF
+c
+      DO ig = 1, klon
+         pctsrf(ig,is_oce) = 0.0
+         pctsrf(ig,is_ter) = 0.0
+         pctsrf(ig,is_lic) = 0.0
+         pctsrf(ig,is_sic) = 0.0
+      ENDDO
+      ok = .TRUE.
+      DO ig = 1, klon
+      IF (NINT(lmt_nat(ig)).EQ.0) THEN
+         pctsrf(ig,is_oce) = 1.0
+      ELSE IF (NINT(lmt_nat(ig)).EQ.1) THEN
+         pctsrf(ig,is_ter) = 1.0
+      ELSE IF (NINT(lmt_nat(ig)).EQ.2) THEN
+         pctsrf(ig,is_lic) = 1.0
+      ELSE IF (NINT(lmt_nat(ig)).EQ.3) THEN
+         pctsrf(ig,is_sic) = 1.0
+      ELSE
+         ok = .FALSE.
+      ENDIF
+      ENDDO
+      IF (.NOT.ok) THEN
+         PRINT*, "valeur fausse pour lmt_nat:", lmt_nat
+         CALL abort
+      ENDIF
+c
+      ENDIF ! fin de test sur newlmt
+c
+c Sea surface temperature:
+      ierr = NF_INQ_VARID (nid, "SST", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <SST> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_sst)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_sst)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <SST>"
+         CALL abort
+      ENDIF
+c
+c Albedo de surface:
+      ierr = NF_INQ_VARID (nid, "ALB", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <ALB> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_alb)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_alb)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <ALB>"
+         CALL abort
+      ENDIF
+c
+c Longueur de rugosite au sol:
+      ierr = NF_INQ_VARID (nid, "RUG", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <RUG> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_rug)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_rug)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <RUG>"
+         CALL abort
+      ENDIF
+c
+c Bilan flux de chaleur au sol:
+      ierr = NF_INQ_VARID (nid, "BILS", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <BILS> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,debut,epais,lmt_bils)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,debut,epais,lmt_bils)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <BILS>"
+         CALL abort
+      ENDIF
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+c
+c
+      PRINT*, 'SST, ALB, RUG, etc. sont lus pour jour: ', jour
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.F	(revision 428)
@@ -0,0 +1,370 @@
+c $Header$
+      SUBROUTINE conema3 (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,
+     .             qcond_incld)
+
+      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"
+#include "conema3.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
+      REAL d_t2(klon,klev), d_q2(klon,klev) ! sbl
+      REAL d_u2(klon,klev), d_v2(klon,klev) ! sbl
+      REAL em_d_t2(klev), em_d_q2(klev)     ! sbl   
+      REAL em_d_u2(klev), em_d_v2(klev)     ! sbl   
+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)
+
+      REAL wd(klon)
+      REAL qcond_incld(klon,klev)
+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
+
+      REAL em_wd
+      REAL em_qcond(klev)
+      REAL em_qcondc(klev)
+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
+
+c -- sb: pour schema nuages:
+
+       integer iflagcon
+       integer em_ifc(klev)
+     
+       real em_pradj
+       real em_cldf(klev), em_cldq(klev)
+       real em_ftadj(klev), em_fradj(klev)
+
+       integer ifc(klon,klev)
+       real pradj(klon)
+       real cldf(klon,klev), cldq(klon,klev)
+       real ftadj(klon,klev), fqadj(klon,klev)
+
+c sb --
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+ 
+      qcond_incld(:,:) = 0.
+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 
+
+c     print*,'avant convect i=',i
+      CALL convect3(dtime,epmax,ok_adj_ema,
+     .              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,
+     .  Qent,TPS,TLS,SIJ,em_CAPE,em_TVP,em_pbase,em_bbase,
+     .  em_dtvpdt1,em_dtvpdq1,em_dplcldt,em_dplcldr, ! sbl
+     .  em_d_t2,em_d_q2,em_d_u2,em_d_v2,em_wd,em_qcond,em_qcondc)!sbl
+c     print*,'apres convect '
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c -- sb: Appel schema statistique de nuages couple a la convection
+c (Bony et Emanuel 2001):
+
+c -- creer cvthermo.h qui contiendra les cstes thermo de LMDZ:
+
+        iflagcon = 3
+c       CALL cv_thermo(iflagcon)
+
+c -- appel schema de nuages:
+
+c       CALL CLOUDS_SUB_LS(klev,em_q,em_qs,em_t
+c    i          ,em_p,em_ph,dtime,em_qcondc
+c    o          ,em_cldf,em_cldq,em_pradj,em_ftadj,em_fradj,em_ifc)
+
+        do k = 1, klev 
+         cldf(i,k)  = em_cldf(k)  ! cloud fraction (0-1)
+         cldq(i,k)  = em_cldq(k)  ! in-cloud water content (kg/kg)
+         ftadj(i,k) = em_ftadj(k) ! (dT/dt)_{LS adj} (K/s)
+         fqadj(i,k) = em_fradj(k) ! (dq/dt)_{LS adj} (kg/kg/s)
+         ifc(i,k)   = em_ifc(k)   ! flag convergence clouds_gno (1 ou 2)
+        enddo
+        pradj(i) = em_pradj       ! precip from LS supersat adj (mm/day)
+
+c sb --
+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
+      wd(i) = em_wd
+      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_t2(i,l) = dtime * em_d_t2(l) 
+         d_q2(i,l) = dtime * em_d_q2(l)
+         d_u2(i,l) = dtime * em_d_u2(l)
+         d_v2(i,l) = dtime * em_d_v2(l)
+
+         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)
+
+         if (iflag_clw.eq.0) then
+            qcond_incld(i,l) = em_qcondc(l)
+         else if (iflag_clw.eq.1) then
+            qcond_incld(i,l) = em_qcond(l)
+         endif
+      ENDDO
+  999 CONTINUE
+
+c   On calcule une eau liquide diagnostique en fonction de la 
+c  precip.
+      if ( iflag_clw.eq.2 ) then
+      do l=1,klev
+         do i=1,klon
+            if (ktop(i)-kbas(i).gt.0.and.
+     s         l.ge.kbas(i).and.l.le.ktop(i)) then
+               qcond_incld(i,l)=rain(i)*8.e4
+c    s         *(pplay(i,l      )-paprs(i,ktop(i)+1))
+     s         /(pplay(i,kbas(i))-pplay(i,ktop(i)))
+c    s         **2
+            else
+               qcond_incld(i,l)=0.
+            endif
+         enddo
+         print*,'l=',l,',   qcond_incld=',qcond_incld(1,l)
+      enddo
+      endif
+ 
+
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conema3.h	(revision 428)
@@ -0,0 +1,5 @@
+      real epmax             ! 0.993
+      logical ok_adj_ema      ! F
+      integer iflag_clw      ! 0
+
+      common/comconema/epmax,ok_adj_ema,iflag_clw
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conemav.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conemav.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conemav.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/conf_phys.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conf_phys.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conf_phys.F90	(revision 428)
@@ -0,0 +1,316 @@
+!
+! $Header$
+!
+
+  subroutine conf_phys(ocean, ok_veget, ok_journe, ok_mensuel, ok_instan, &
+ &                     fact_cldcon, facttemps,ok_newmicro,iflag_cldcon, &
+ &                     ratqsbas,ratqshaut,if_ebil)
+
+   use IOIPSL
+   implicit none
+
+#include "conema3.h"
+#include "fisrtilp.inc"
+#include "nuage.h"
+!
+! 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, ok_newmicro
+  logical              :: ok_journe, ok_mensuel, ok_instan
+  real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut
+  integer              :: iflag_cldcon, if_ebil
+! 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)
+!
+!Config Key  = if_ebil
+!Config Desc = Niveau de sortie pour les diags bilan d'energie 
+!Config Def  = 0
+!Config Help = 
+!               
+!
+  if_ebil = 0
+  call getin('if_ebil', if_ebil)
+!!
+!! KE
+!
+!Config Key  = epmax
+!Config Desc = Efficacite precip
+!Config Def  = 0.993
+!Config Help = 
+!
+  epmax = .993
+  call getin('epmax', epmax)
+!
+!Config Key  = ok_adj_ema
+!Config Desc =  
+!Config Def  = false
+!Config Help = 
+!
+  ok_adj_ema = .false.
+  call getin('ok_adj_ema',ok_adj_ema)
+!
+!Config Key  = iflag_clw
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clw = 0
+  call getin('iflag_clw',iflag_clw)
+!
+!Config Key  = cld_lc_lsc 
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_lsc = 2.6e-4
+  call getin('cld_lc_lsc',cld_lc_lsc)
+!
+!Config Key  = cld_lc_con
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_con = 2.6e-4
+  call getin('cld_lc_con',cld_lc_con)
+!
+!Config Key  = cld_tau_lsc
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_lsc = 3600.
+  call getin('cld_tau_lsc',cld_tau_lsc)
+!
+!Config Key  = cld_tau_con
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_con = 3600.
+  call getin('cld_tau_con',cld_tau_con)
+!
+!Config Key  = ffallv_lsc
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_lsc = 1.
+  call getin('ffallv_lsc',ffallv_lsc)
+!
+!Config Key  = ffallv_con
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_con = 1.
+  call getin('ffallv_con',ffallv_con)
+!
+!Config Key  = coef_eva
+!Config Desc =  
+!Config Def  = 2.e-5
+!Config Help = 
+!
+  coef_eva = 2.e-5
+  call getin('coef_eva',coef_eva)
+!
+!Config Key  = reevap_ice
+!Config Desc =  
+!Config Def  = .false.
+!Config Help = 
+!
+  reevap_ice = .false.
+  call getin('reevap_ice',reevap_ice)
+!
+!Config Key  = iflag_cldcon 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_cldcon = 1
+  call getin('iflag_cldcon',iflag_cldcon)
+
+!
+!Config Key  = iflag_pdf 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_pdf = 0
+  call getin('iflag_pdf',iflag_pdf)
+!
+!Config Key  = fact_cldcon
+!Config Desc =  
+!Config Def  = 0.375
+!Config Help = 
+!
+  fact_cldcon = 0.375
+  call getin('fact_cldcon',fact_cldcon)
+
+!
+!Config Key  = facttemps
+!Config Desc =  
+!Config Def  = 1.e-4
+!Config Help = 
+!
+  facttemps = 1.e-4
+  call getin('facttemps',facttemps)
+
+!
+!Config Key  = ok_newmicro
+!Config Desc =  
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_newmicro = .true.
+  call getin('ok_newmicro',ok_newmicro)
+!
+!Config Key  = ratqsbas
+!Config Desc =  
+!Config Def  = 0.01
+!Config Help = 
+!
+  ratqsbas = 0.01
+  call getin('ratqsbas',ratqsbas)
+!
+!Config Key  = ratqshaut
+!Config Desc =  
+!Config Def  = 0.3
+!Config Help = 
+!
+  ratqshaut = 0.3
+  call getin('ratqshaut',ratqshaut)
+
+!
+!Config Key  = rad_froid
+!Config Desc =  
+!Config Def  = 35.0
+!Config Help = 
+!
+  rad_froid = 35.0
+  call getin('rad_froid',rad_froid)
+
+!
+!Config Key  = rad_chau1
+!Config Desc =  
+!Config Def  = 13.0
+!Config Help = 
+!
+  rad_chau1 = 13.0
+  call getin('rad_chau1',rad_chau1)
+
+!
+!Config Key  = rad_chau2
+!Config Desc =  
+!Config Def  = 9.0
+!Config Help = 
+!
+  rad_chau2 = 9.0
+  call getin('rad_chau2',rad_chau2)
+
+!
+!Config Key  = 
+!Config Desc =  
+!Config Def  =
+!Config Help = 
+!
+!   =
+!  call getin('',)
+!
+!
+!
+!
+
+  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
+  write(numout,*)' Sortie bilan d''energie, if_ebil =', if_ebil
+  write(numout,*)' epmax = ', epmax
+  write(numout,*)' ok_adj_ema = ', ok_adj_ema
+  write(numout,*)' iflag_clw = ', iflag_clw
+  write(numout,*)' cld_lc_lsc = ', cld_lc_lsc
+  write(numout,*)' cld_lc_con = ', cld_lc_con
+  write(numout,*)' cld_tau_lsc = ', cld_tau_lsc
+  write(numout,*)' cld_tau_con = ', cld_tau_con
+  write(numout,*)' ffallv_lsc = ', ffallv_lsc
+  write(numout,*)' ffallv_con = ', ffallv_con
+  write(numout,*)' coef_eva = ', coef_eva
+  write(numout,*)' reevap_ice = ', reevap_ice
+  write(numout,*)' iflag_pdf = ', iflag_pdf
+  write(numout,*)' iflag_cldcon = ', iflag_cldcon
+  write(numout,*)' fact_cldcon = ', fact_cldcon
+  write(numout,*)' facttemps = ', facttemps
+  write(numout,*)' ok_newmicro = ',ok_newmicro 
+  write(numout,*)' ratqsbas = ',ratqsbas 
+  write(numout,*)' ratqshaut = ',ratqshaut 
+
+  return
+
+  end subroutine conf_phys
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conflx.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conflx.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conflx.F	(revision 428)
@@ -0,0 +1,1660 @@
+      SUBROUTINE conflx (dtime,pres_h,pres_f,
+     e                   t, q, con_t, con_q, pqhfl, w,
+     s                   d_t, d_q, rain, snow,
+     s                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+c Objet: Schema flux de masse pour la convection 
+c        (schema de Tiedtke avec qqs modifications mineures)
+c Dec.97: Prise en compte des modifications introduites par
+c         Olivier Boucher et Alexandre Armengaud pour melange
+c         et lessivage des traceurs passifs.
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+cAA
+
+c
+      INTEGER i, k
+      REAL zdelta, zqsat
+c
+#include "FCTTRE.h"
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))
+     .                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)
+     .              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)
+     .                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,
+     .             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,
+     .             rain, snow, kcbot, kctop, kdtop,
+     .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
+C
+cAA--------------------------------------------------------
+cAA rem : De la meme facon que l'on effectue le reindicage 
+cAA       pour la temperature t et le champ q 
+cAA       on reindice les flux necessaires a la convection 
+cAA       des traceurs
+cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+     
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      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
+c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,
+     .                   pgeo, ldland, ptte, pqte, pvervel,
+     .                   prsfc, pssfc, kcbot, kctop, kdtop,
+c     *                   ldcum, ktype,
+     .                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .                   dt_con, dq_con, pmflxr, pmflxs)
+      IMPLICIT none
+C     ------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+c----------------------------------------------------------------------
+c initialiser les variables et faire l'interpolation verticale
+c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,
+     .     paph, zgeoh, ztenh, zqenh, zqsenh,
+     .     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,
+     .     pmfu, zmfus, zmfuq, zdmfup,
+     .     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+c---------------------------------------------------------------------
+c determiner les valeurs au niveau de base de la tour convective
+c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,
+     *            ptu, pqu, plu, ldcum, kcbot, ilab)
+c---------------------------------------------------------------------
+c calculer la convergence totale de l'humidite et celle en provenance
+c de la couche limite, plus precisement, la convergence integree entre
+c le sol et la base de la convection. Cette derniere convergence est
+c comparee avec l'evaporation obtenue dans la couche limite pour
+c determiner le type de la convection
+c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))
+     .                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         ktype(i) = 2
+         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
+c---------------------------------------------------------------------
+c determiner le flux de masse entrant a travers la base.
+c on ignore, pour l'instant, l'effet du panache descendant
+c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+C-----------------------------------------------------------------------
+C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+C-----------------------------------------------------------------------
+c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+c     considerer l'entrainement ni le detrainement du panache, sachant
+c     ces derniers peuvent abaisser la hauteur theorique.
+c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/
+     .        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*
+     .               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+c
+c (B) calculer le panache ascendant
+c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+C
+C verifier l'epaisseur de la convection et changer eventuellement
+c le taux d'entrainement/detrainement
+C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+c
+c calculer la precipitation issue du panache ascendant pour 
+c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+c
+c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,
+     *     ldcum,    kcbot,    kctop,    zmfub,    zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     kdtop,    lddraf)
+c
+c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,
+     *     zgeoh,    paph,     zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     lddraf, pen_d, pde_d)
+c
+c calculer de nouveau le flux de masse entrant a travers la base
+c de la convection, sachant qu'il a ete modifie par le panache
+c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-
+     .            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)
+     .       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-
+     .            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.
+     .              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )
+     .      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+c
+      ENDIF   ! fin de test sur lmfdd
+c
+c-----------------------------------------------------------------------
+c calculer de nouveau le panache ascendant
+c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+c
+c-----------------------------------------------------------------------
+c determiner les flux convectifs en forme finale, ainsi que
+c la quantite des precipitations
+c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, 
+     .     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,
+     .     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,
+     .     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,
+     .     pmflxr, pmflxs)
+c
+c----------------------------------------------------------------------
+c calculer les tendances pour T et Q
+c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,
+     e     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,
+     s     dt_con,dq_con)
+c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,
+     .           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,
+     .           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,
+     .           klab,pen_u, pde_u, pen_d, pde_d)
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+C AND INITIALIZES VALUES FOR UPDRAFTS
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+C----------------------------------------------------------------------
+C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),
+     .             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))
+     .               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+c
+  130 CONTINUE
+C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-
+     1                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),
+     .             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+C
+C-----------------------------------------------------------------------
+C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+c
+         klab(i,k) = 0
+c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,
+     *     ptu, pqu, plu, ldcum, kcbot, klab)
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+C
+C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+C   klab=1 FOR SUBCLOUD LEVELS
+C   klab=2 FOR CONDENSATION LEVEL
+C
+C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+C----------------------------------------------------------------------
+C INITIALIZE VALUES AT LIFTING LEVEL
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C DO ASCENT IN SUBCLOUD LAYER,
+C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+C ADJUST T,Q AND L ACCORDINGLY
+C CHECK FOR BUOYANCY AND SET FLAGS
+C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+  290 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,
+     .     pgeo, pgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, klab, ptu, pqu, plu,
+     .     pmfu, pmfub, pentr, pmfus, pmfuq,
+     .     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,
+     .     pen_u, pde_u)
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+C FOR CUMULUS PARAMETERIZATION
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+c
+c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+C SET DEFAULT VALUES
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+C
+C Initialiser les valeurs au niveau d'ascendance
+C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.
+     .       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+c
+c calculer le taux d'entrainement et de detrainement
+c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.
+     .        (zpbot(i)-paph(i,k).LT.0.2E5.OR.
+     .         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.
+     .        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)
+     .   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*
+     .              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+C----------------------------------------------------------------------
+c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-
+     1               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+C----------------------------------------------------------------------
+c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+C
+  480 CONTINUE
+C----------------------------------------------------------------------
+C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+C           FROM PREVIOUS CALCULATIONS ABOVE)
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+c
+      ldcum(1)=ldcum(1)
+c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap
+     .  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop
+     .  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds
+     .  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp
+     .  ,  pten, prfl, psfl, pdpmel, ktopm2
+     .  ,  pmflxr, pmflxs)
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL cevapcu(klev)
+C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(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, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+c
+#include "FCTTRE.h"
+c
+      DO 101 k=1,klev
+      CEVAPCU(k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)
+     1 *SQRT(0.5*(paph(1,k)+paph(1,k+1))/paph(1,klev+1)) ) * 0.5/RG
+ 101  CONTINUE
+c
+c SPECIFY CONSTANTS
+c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+c
+c DETERMINE FINAL CONVECTIVE FLUXES
+c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*
+     .                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+c
+c        l'eau liquide detrainee est precipitee quand certaines
+c        conditions sont reunies (sinon, elle est consideree
+c        evaporee dans l'environnement)
+c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.
+     .      pqen(i,k-1).GT.0.8*pqsen(i,k-1))
+     .      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*
+     .                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/
+     .        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+c
+c CALCULATE RAIN/SNOW FALL RATES
+c CALCULATE MELTING OF SNOW
+c CALCULATE EVAPORATION OF PRECIP
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         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)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+c        si la precipitation est negative, on ajuste le plux du
+c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      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
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-
+     .            CEVAPCU(k)*(paph(i,k+1)-paph(i,k))*
+     .            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))
+     .            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            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
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)
+     .                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)
+     .                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten
+     .  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp
+     .  ,  pdpmel, dt_con, dq_con)
+      IMPLICIT none
+c----------------------------------------------------------------------
+c calculer les tendances T et Q
+c----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     -----------------------------------------------------------------
+      LOGICAL  llo1
+C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+c
+      INTEGER ktopm2
+      REAL pdtime
+c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .        *(pmfus(i,k+1)-pmfus(i,k)
+     .         +pmfds(i,k+1)-pmfds(i,k)
+     .          -RLMLT*pdpmel(i,k)
+     .          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+     .         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))
+     .        *(pmfuq(i,k+1)-pmfuq(i,k)
+     .         +pmfdq(i,k+1)-pmfdq(i,k)
+     .          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)
+     .           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))
+     .            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)
+     .             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,
+     .     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,
+     .     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+C
+C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+C FOR MASSFLUX CUMULUS PARAMETERIZATION
+C
+C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+C
+C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+C
+C----------------------------------------------------------------------
+C DETERMINE LEVEL OF FREE SINKING BY
+C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+C
+C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+C     (3) CHECK FOR NEGATIVE BUOYANCY
+C
+C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+C EVAPORATION OF RAIN AND CLOUD WATER)
+C----------------------------------------------------------------------
+C
+      DO 290 k = 3, klev-3
+C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.
+     .             .AND..NOT.lddraf(i)
+     .             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+C
+C----------------------------------------------------------------------
+C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+C AND CHECK FOR NEGATIVE BUOYANCY.
+C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-
+     .        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+c
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,
+     .           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,
+     .           lddraf, pen_d, pde_d)
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+C
+C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+C          (I.E. T,Q,U AND V AND FLUXES)
+C
+C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+C
+C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+C
+C----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+C----------------------------------------------------------------------
+C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+C           LINEAR DECREASE OF MASSFLUX IN PBL
+C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+C
+      DO 180 k = 3, klev
+c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/
+     .           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*
+     .      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-
+     .               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-
+     .          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      IMPLICIT none
+c======================================================================
+c Objet: ajustement entre T et Q
+c======================================================================
+C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+C        kcall=0    ENV. T AND QS IN*CUINI*
+C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+C
+C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+C
+#include "YOECUMF.h"
+C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conlmd.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conlmd.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/conlmd.F	(revision 428)
@@ -0,0 +1,2305 @@
+      SUBROUTINE conlmd (dtime, paprs, pplay, t, q, conv_q,
+     s                   d_t, d_q, rain, snow, ibas, itop)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection utilis'e dans le modele du LMD
+c        Ajustement humide (Manabe) + Ajustement convectif (Kuo)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL conv_q(klon,klev)  ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL usekuo ! utiliser convection profonde (schema Kuo)
+      PARAMETER (usekuo=.TRUE.)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL rain_bis(klon)
+      REAL snow_bis(klon)
+      INTEGER ibas_bis(klon)
+      INTEGER itop_bis(klon)
+      REAL d_ql(klon,klev), d_ql_bis(klon,klev)
+      REAL rneb(klon,klev), rneb_bis(klon,klev)
+c
+      INTEGER i, k
+      REAL zlvdcp, zlsdcp, zdelta, zz, za, zb
+c
+ccc      CALL fiajh ! ancienne version de Convection Manabe
+      CALL conman ! nouvelle version de Convection Manabe
+     e     (dtime, paprs, pplay, t, q,
+     s      d_t, d_q, d_ql, rneb,
+     s      rain, snow, ibas, itop)
+c
+      IF (usekuo) THEN
+ccc      CALL fiajc ! ancienne version de Convection Kuo
+      CALL conkuo ! nouvelle version de Convection Kuo
+     e     (dtime, paprs, pplay, t, q, conv_q,
+     s      d_t_bis, d_q_bis, d_ql_bis, rneb_bis, 
+     s      rain_bis, snow_bis, ibas_bis, itop_bis)
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = d_t(i,k) + d_t_bis(i,k)
+         d_q(i,k) = d_q(i,k) + d_q_bis(i,k)
+         d_ql(i,k) = d_ql(i,k) + d_ql_bis(i,k)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = rain(i) + rain_bis(i)
+         snow(i) = snow(i) + snow_bis(i)
+         ibas(i) = MIN(ibas(i),ibas_bis(i))
+         itop(i) = MAX(itop(i),itop_bis(i))
+      ENDDO
+      ENDIF
+c
+c L'eau liquide convective est dispersee dans l'air:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t(i,k)))
+         zz = d_ql(i,k) ! re-evap. de l'eau liquide
+         zb = MAX(0.0,zz)
+         za = - MAX(0.0,zz) * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         d_t(i,k) = d_t(i,k) + za
+         d_q(i,k) = d_q(i,k) + zb
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE conman (dtime, paprs, pplay, t, q,
+     s                   d_t, d_q, d_ql, rneb,
+     s                   rain, snow, ibas, itop)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19970324
+c Objet: ajustement humide convectif avec la possibilite de faire
+c        l'ajustement sur une fraction de la maille.
+c Methode: On impose une distribution uniforme pour la vapeur d'eau
+c au sein d'une maille. On applique la procedure d'ajustement
+c successivement a la totalite, 75%, 50%, 25% et 5% de la maille
+c jusqu'a ce que l'ajustement a lieu. J'espere que ceci augmente
+c les activites convectives et corrige le biais "trop froid et sec"
+c du modele.
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+c
+      LOGICAL afaire(klon)   ! .TRUE. implique l'ajustement
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement est effectif
+c
+      INTEGER nb ! nombre de sous-fractions a considere
+      PARAMETER (nb=1)
+ccc      PARAMETER (nb=3)
+c
+      REAL ratqs ! largeur de la distribution pour vapeur d'eau
+      PARAMETER (ratqs=0.05)
+c
+      REAL w_q(klon,klev)
+      REAL w_d_t(klon,klev), w_d_q(klon,klev), w_d_ql(klon,klev)
+      REAL w_rneb(klon,klev)
+      REAL w_rain(klon), w_snow(klon)
+      INTEGER w_ibas(klon), w_itop(klon)
+      REAL zq1, zq2
+      INTEGER i, k, n
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL zdp1, zdp2
+      REAL zqs1, zqs2, zdqs1, zdqs2
+      REAL zgamdz
+      REAL zflo ! flotabilite
+      REAL zsat ! sur-saturation
+      REAL zdelta, zcor, zcvm5
+      LOGICAL imprim
+c
+      INTEGER ncpt
+      SAVE ncpt
+      REAL frac(nb) ! valeur de la maille fractionnelle
+      SAVE frac
+      INTEGER opt_cld(nb) ! option pour le modele nuageux
+      SAVE opt_cld
+      LOGICAL appel1er
+      SAVE appel1er
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA frac / 1.0 /
+      DATA opt_cld / 4 /
+ccc      DATA frac    / 1.0, 0.50, 0.25/
+ccc      DATA opt_cld / 4,   4,    4/
+c
+      DATA appel1er /.TRUE./
+      DATA ncpt /0/
+c
+      IF (appel1er) THEN
+         PRINT*, 'conman, nb:', nb
+         PRINT*, 'conman, frac:', frac
+         PRINT*, 'conman, opt_cld:', opt_cld
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c S'il n'y a pas d'instabilite conditionnelle,
+c pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         afaire(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev-1
+      DO i = 1, klon
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+            zqs1= R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+            zqs1=MIN(0.5,zqs1)
+            zcor=1./(1.-RETV*zqs1)
+            zqs1=zqs1*zcor
+            zdqs1 =FOEDE(t(i,k),zdelta,zcvm5,zqs1,zcor)
+c
+            zdelta=MAX(0.,SIGN(1.,RTT-t(i,k+1)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k+1))
+            zqs2= R2ES*FOEEW(t(i,k+1),zdelta)/pplay(i,k+1)
+            zqs2=MIN(0.5,zqs2)
+            zcor=1./(1.-RETV*zqs2)
+            zqs2=zqs2*zcor
+            zdqs2 =FOEDE(t(i,k+1),zdelta,zcvm5,zqs2,zcor)
+         ELSE
+           IF (t(i,k) .LT. t_coup) THEN
+              zqs1= qsats(t(i,k)) / pplay(i,k)
+              zdqs1= dqsats(t(i,k),zqs1)
+c
+              zqs2= qsats(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsats(t(i,k+1),zqs2)
+           ELSE
+              zqs1= qsatl(t(i,k)) / pplay(i,k)
+              zdqs1= dqsatl(t(i,k),zqs1)
+c
+              zqs2= qsatl(t(i,k+1)) / pplay(i,k+1)
+              zdqs2= dqsatl(t(i,k+1),zqs2)
+           ENDIF
+         ENDIF
+         zdp1 = paprs(i,k) - paprs(i,k+1)
+         zdp2 = paprs(i,k+1) - paprs(i,k+2)
+         zgamdz = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(t(i,k)*zdp1+t(i,k+1)*zdp2)/(zdp1+zdp2)
+     .            +RLVTT*(zqs1*zdp1+zqs2*zdp2)/(zdp1+zdp2)
+     .           ) / (1.0+(zdqs1*zdp1+zdqs2*zdp2)/(zdp1+zdp2) )
+         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) afaire(i) = .TRUE.
+c erreur         IF (zflo.GT.0.0 .AND. zsat.GT.0.0) afaire(i) = .TRUE.
+      ENDDO
+      ENDDO
+c
+      imprim = MOD(ncpt,48).EQ.0
+      DO 99999 n = 1, nb
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zq1 = q(i,k) * (1.0-ratqs)
+         zq2 = q(i,k) * (1.0+ratqs)
+         w_q(i,k) = zq2 - frac(n)/2.0 * (zq2-zq1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      CALL conmanv (dtime, paprs, pplay, t, w_q,
+     e              afaire, opt_cld(n),
+     s              w_d_t, w_d_q, w_d_ql, w_rneb,
+     s              w_rain, w_snow, w_ibas, w_itop,accompli,imprim)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         d_t(i,k) = w_d_t(i,k) * frac(n)
+         d_q(i,k) = w_d_q(i,k) * frac(n)
+         d_ql(i,k) = w_d_ql(i,k) * frac(n)
+         IF (NINT(w_rneb(i,k)).EQ.1) rneb(i,k) = frac(n)
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (afaire(i) .AND. accompli(i)) THEN
+         rain(i) = w_rain(i) * frac(n)
+         snow(i) = w_snow(i) * frac(n)
+         ibas(i) = MIN(ibas(i),w_ibas(i))
+         itop(i) = MAX(itop(i),w_itop(i))
+      ENDIF
+      ENDDO
+      DO i = 1, klon
+         IF(afaire(i) .AND. accompli(i)) afaire(i) = .FALSE.
+      ENDDO
+c
+99999 CONTINUE
+c
+      ncpt = ncpt + 1
+c
+      RETURN
+      END
+      SUBROUTINE conmanv (dtime, paprs, pplay, t, q,
+     e                    afaire, opt_cld,
+     s                    d_t, d_q, d_ql, rneb,
+     s                    rain, snow, ibas, itop,accompli,imprim)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: ajustement humide (convection proposee par Manabe).
+c        Pour une colonne verticale, il peut avoir plusieurs blocs
+c        necessitant l'ajustement. ibas est le bas du plus bas bloc
+c        et itop est le haut du plus haut bloc
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime              ! pas d'integration (s)
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      LOGICAL afaire(klon) ! .TRUE. si le point est a faire (Input)
+      LOGICAL imprim ! .T. pour imprimer quelques diagnostiques
+c
+      REAL d_t(klon,klev)     ! incrementation temperature
+      REAL d_q(klon,klev)     ! incrementation humidite
+      REAL d_ql(klon,klev)    ! incrementation eau liquide
+      REAL rneb(klon,klev)    ! nebulosite
+      REAL rain(klon)         ! pluies (mm/s)
+      REAL snow(klon)         ! neige (mm/s)
+      INTEGER ibas(klon)      ! niveau du bas
+      INTEGER itop(klon)      ! niveau du haut
+      LOGICAL accompli(klon) ! .TRUE. si l'ajustement a eu lieu (Output)
+c
+c Quelques options:
+c
+      LOGICAL new_top ! re-calculer sommet quand re-ajustement est fait
+      PARAMETER (new_top=.FALSE.)
+      LOGICAL evap_prec ! evaporation de pluie au-dessous de convection
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+      LOGICAL old_tau ! implique precip nulle, si vrai.
+      PARAMETER (old_tau=.FALSE.)
+      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.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      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:
+c
+      INTEGER nexpo
+      INTEGER i, k, k1min, k1max, k2min, k2max, is
+      REAL zgamdz(klon,klev-1)
+      REAL zt(klon,klev), zq(klon,klev)
+      REAL zqs(klon,klev), zdqs(klon,klev)
+      REAL zqmqsdp(klon,klev)
+      REAL ztnew(klon,klev), zqnew(klon,klev)
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zsat(klon) ! sur-saturation
+      REAL zflo(klon) ! flotabilite
+      REAL za(klon), zb(klon), zc(klon)
+      INTEGER k1(klon), k2(klon)
+      REAL zdelta, zcor, zcvm5
+      REAL delp(klon,klev)
+      LOGICAL possible(klon), todo(klon), etendre(klon)
+      LOGICAL aller(klon), todobis(klon)
+      REAL zalfa
+      INTEGER nbtodo, nbdone
+c
+c Fonctions thermodynamiques:
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k) - paprs(i,k+1)
+      ENDDO
+      ENDDO
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         ibas(i) = klev
+         itop(i) = 1
+         rain(i) = 0.0
+         snow(i) = 0.0
+         accompli(i) = .FALSE.
+      ENDDO
+c
+c Preparations
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zt(i,k) = t(i,k)
+         zq(i,k) = q(i,k) 
+c
+c        Calculer Qs et L/Cp*dQs/dT
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+c
+c        Calculer (q-qs)*dp
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k)) * delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c-----zgama is the moist convective lapse rate (-dT/dz).
+c-----zgamdz(*,k) est la difference minimale autorisee des temperatures
+c-----entre deux couches (k et k+1), c.a.d. si T(k+1)-T(k) est inferieur
+c-----a zgamdz(*,k), alors ces 2 couches sont instables conditionnellement
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c On cherche la presence simultanee d'instabilite conditionnelle
+c et de sur-saturation. Sinon, pas la penne de se fatiguer:
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+      IF (afaire(i)) THEN
+         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).GT.0.0 .AND. zsat(i).GT.0.0) possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (possible(i)) THEN
+         k1(i) = kbase
+         k2(i) = k1(i) + 1
+      ENDIF
+      ENDDO
+c
+  810 CONTINUE ! chercher le bas de la colonne a ajuster
+c
+      k2min = klev
+      DO i = 1, klon
+         todo(i) = .FALSE.
+         aller(i) = .TRUE.
+         IF (possible(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.EQ.klev) GOTO 860
+      DO k = k2min, klev-1
+      DO i = 1, klon
+      IF (possible(i) .AND. k.GE.k2(i) .AND. aller(i)) THEN
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k+1)
+         IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+            k1(i) = k
+            k2(i) = k+1
+            todo(i) = .TRUE.
+            aller(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+      IF (possible(i).AND.aller(i)) THEN
+         todo(i) = .FALSE.
+         k1(i) = klev
+         k2(i) = klev
+      ENDIF
+      ENDDO
+c
+CCC      DO i = 1, klon
+CCC      IF (possible(i)) THEN
+CCC  811    k2(i) = k2(i) + 1
+CCC         IF (k2(i) .GT. klev) THEN
+CCC            todo(i) = .FALSE.
+CCC            GOTO 812
+CCC         ENDIF
+CCC         k = k2(i)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 811
+CCC         k1(i) = k2(i) - 1
+CCC         todo(i) = .TRUE.
+CCC      ENDIF
+CCC  812 CONTINUE
+CCC      ENDDO
+c
+  820 CONTINUE ! chercher le haut de la colonne
+c
+      k2min = klev
+      DO i = 1, klon
+         aller(i) = .TRUE.
+         IF (todo(i)) k2min = MIN(k2min,k2(i))
+      ENDDO
+      IF (k2min.LT.klev) THEN
+      DO k = k2min, klev
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GT.k2(i) .AND. aller(i)) THEN
+            zsat(i) = zsat(i) + zqmqsdp(i,k)
+            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+            IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+               aller(i) = .FALSE.
+            ELSE
+               k2(i) = k
+            ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c error      is = 0
+c error      DO i = 1, klon
+c error      IF(todo(i).AND.aller(i)) THEN
+c error         is = is + 1
+c error         todo(i) = .FALSE.
+c error         k2(i) = klev
+c error      ENDIF
+c error      ENDDO
+c error      IF (is.GT.0) THEN
+c error         PRINT*, "Bizard. je pourrais continuer mais j arrete"
+c error         CALL abort
+c error      ENDIF
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (todo(i)) THEN
+CCC  821    CONTINUE
+CCC         IF (k2(i) .EQ. klev) GOTO 822
+CCC         k = k2(i) + 1
+CCC         zsat(i) = zsat(i) + zqmqsdp(i,k)
+CCC         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) GOTO 822
+CCC         k2(i) = k
+CCC         GOTO 821
+CCC      ENDIF
+CCC  822 CONTINUE
+CCC      ENDDO
+c
+  830 CONTINUE ! faire l'ajustement en sachant k1 et k2
+c
+      is = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (k2(i).LE.k1(i)) is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         PRINT*, "Impossible: k1 trop grand ou k2 trop petit"
+         PRINT*, "is=", is
+         CALL abort
+      ENDIF
+c
+      k1min = klev
+      k1max = 1
+      k2max = 1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k1min = MIN(k1min,k1(i))
+         k1max = MAX(k1max,k1(i))
+         k2max = MAX(k2max,k2(i))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      k = k1(i)
+      za(i) = 0.
+      zb(i) = ( RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .      -RLVTT*(zqs(i,k)-zq(i,k)) )*delp(i,k)
+      zc(i) = delp(i,k) * RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         za(i) = za(i) + zgamdz(i,k-1)
+         zb(i) = zb(i)+(RCPD*(1.+zdqs(i,k))*(zt(i,k)-za(i))
+     .           -RLVTT*(zqs(i,k)-zq(i,k)) ) * delp(i,k)
+         zc(i) = zc(i) + delp(i,k)*RCPD*(1.+zdqs(i,k))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         k = k1(i)
+         ztnew(i,k) = zb(i)/zc(i)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                          *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i)) THEN
+         ztnew(i,k) = ztnew(i,k-1) + zgamdz(i,k-1)
+         zqnew(i,k) = zqs(i,k) + (ztnew(i,k)-zt(i,k))
+     .                        *RCPD/RLVTT*zdqs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Quantite de condensation produite pendant l'ajustement:
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         rneb(i,k) = 1.0
+         zcond(i) = zcond(i) + (zq(i,k)-zqnew(i,k)) *delp(i,k)/RG
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Si condensation negative, effort completement perdu:
+c
+      DO i = 1, klon
+         IF (todo(i).AND.zcond(i).LE.0.) todo(i) = .FALSE.
+      ENDDO
+c
+c L'ajustement a ete accompli, meme les calculs accessoires
+c ne sont pas encore faits:
+c
+      DO i = 1, klon
+         IF (todo(i)) accompli(i) = .TRUE.
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,k1(i))-paprs(i,k2(i)+1))
+     .                 /paprs(i,1)-dpmin)
+     .                 *(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
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de 
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + zqnew(i,k)*delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+            zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + zrapp(i) * zqnew(i,k)
+         ENDIF
+         ENDDO
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i))
+     .      zvapo(i) = zvapo(i) + MAX(0.0,zq(i,k)-zqnew(i,k)) 
+     .                          * delp(i,k)/RG
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i) .AND.
+     .       zvapo(i).GT.0.0)
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,zq(i,k)-zqnew(i,k))
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse 
+         ENDDO                       ! (avec ponderation)
+         DO k = k1min, k2max
+         DO i = 1, klon
+            IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .         zvapo(i) = zvapo(i) + delp(i,k) / RG
+     .                    * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO k = k1min, k2max
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(k1(i)+1) .AND. k.LE.k2(i))
+     .      d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,k1(i))-pplay(i,k))**nexpo
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+            IF (todo(i)) zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre evaporee:
+c
+      zalfa = 0.05
+      IF (evap_prec .AND. (k1max.GE.2)) THEN
+      DO k = k1max-1, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LT.k1(i) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-zq(i,k))*zalfa )
+         zqevt = coef_eva * (1.0-zq(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .         * delp(i,k)/pplay(i,k)*zt(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) * RG*dtime/delp(i,k)
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(delp(i,k))/RG/dtime
+         zq(i,k) = zq(i,k) - (zrfln-zrfl(i)) 
+     .                     * (RG/(delp(i,k)))*dtime
+         zt(i,k) = zt(i,k) + (zrfln-zrfl(i))
+     .                     * (RG/(delp(i,k)))*dtime
+     .                     * RLVTT/RCPD/(1.0+RVTMP2*zq(i,k))
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (zt(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+c Mise a jour de la temperature et de l'humidite
+c
+      DO k = k1min, k2max
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.k1(i) .AND. k.LE.k2(i)) THEN
+         zt(i,k) = ztnew(i,k)
+         zq(i,k) = zqnew(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Re-calculer certaines variables pour etendre et re-ajuster la colonne
+c
+      IF (exigent) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-zt(i,k)))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i,k))
+            zqs(i,k)= R2ES*FOEEW(zt(i,k),zdelta)/pplay(i,k)
+            zqs(i,k)=MIN(0.5,zqs(i,k))
+            zcor=1./(1.-RETV*zqs(i,k))
+            zqs(i,k)=zqs(i,k)*zcor
+            zdqs(i,k) =FOEDE(zt(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (zt(i,k) .LT. t_coup) THEN
+              zqs(i,k)= qsats(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsats(zt(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k)= qsatl(zt(i,k)) / pplay(i,k)
+              zdqs(i,k)= dqsatl(zt(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (exigent) THEN
+      DO k = 1, klev-1
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zgamdz(i,k) = - (pplay(i,k)-pplay(i,k+1))/paprs(i,k+1)/RCPD
+     .          *( RD*(zt(i,k)*delp(i,k)+zt(i,k+1)*delp(i,k+1))
+     .               /(delp(i,k)+delp(i,k+1))
+     .            +RLVTT*(zqs(i,k)*delp(i,k)+zqs(i,k+1)*delp(i,k+1))
+     .                  /(delp(i,k)+delp(i,k+1))
+     .           ) / (1.0+(zdqs(i,k)*delp(i,k)+zdqs(i,k+1)*delp(i,k+1))
+     .                   /(delp(i,k)+delp(i,k+1)) )
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c Puisque l'humidite a ete modifiee, on re-fait (q-qs)*dp
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         zqmqsdp(i,k) = (zq(i,k)-zqs(i,k))*delp(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Verifier si l'on peut etendre le bas de la colonne
+c
+      DO i = 1, klon
+         etendre(i) = .FALSE.
+      ENDDO
+c
+      k1max = 1
+      DO i = 1, klon
+      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)
+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
+            k1max = MAX(k1max,k1(i))
+            aller(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+c
+      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
+         zsat(i) = zsat(i) + zqmqsdp(i,k)
+         zflo(i) = zt(i,k) + zgamdz(i,k) - zt(i,k+1)
+         IF (zsat(i).LE.0.0 .OR. zflo(i).LE.0.0) THEN
+            aller(i) = .FALSE.
+         ELSE
+            k1(i) = k
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (etendre(i).AND.aller(i)) THEN
+            k1(i) = 1
+         ENDIF
+      ENDDO
+      ENDIF
+c
+CCC      DO i = 1, klon
+CCC      IF (etendre(i)) THEN
+CCC  840    k = k1(i)
+CCC         IF (k.GT.1) THEN
+CCC            zsat(i) = zsat(i) + zqmqsdp(i,k-1)
+CCC            zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+CCC            IF (zflo(i).GT.0.0 .AND. zsat(i).GT.0.0) THEN
+CCC               k1(i) = k - 1
+CCC               GOTO 840
+CCC            ENDIF
+CCC         ENDIF
+CCC      ENDIF
+CCC      ENDDO
+c
+      DO i = 1, klon
+         todobis(i) = todo(i)
+         todo(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (etendre(i)) THEN
+         todo(i) = .TRUE.
+         is = is + 1
+      ENDIF
+      ENDDO
+      IF (is.GT.0) THEN
+         IF (new_top) THEN
+            GOTO 820 ! chercher de nouveau le sommet k2
+         ELSE
+            GOTO 830 ! supposer que le sommet est celui deja trouve
+         ENDIF
+      ENDIF
+c
+      DO i = 1, klon
+         possible(i) = .FALSE.
+      ENDDO
+      is = 0
+      DO i = 1, klon
+      IF (todobis(i) .AND. k2(i).LT.klev) THEN
+         is = is + 1
+         possible(i) = .TRUE.
+      ENDIF
+      ENDDO
+      IF (is.GT.0) GOTO 810 !on cherche en haut d'autres blocks 
+c     a ajuster a partir du sommet de la colonne precedente
+c
+  860 CONTINUE ! Calculer les tendances et diagnostiques
+ccc      print*, "Apres 860"
+c
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (accompli(i)) THEN
+         d_t(i,k) = zt(i,k) - t(i,k)
+         zq(i,k) = MAX(zq(i,k),seuil_vap)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 888 i = 1, klon
+      IF (accompli(i)) THEN
+         DO k = 1, klev
+         IF (rneb(i,k).GT.0.0) THEN
+            ibas(i) = k
+            GOTO 807
+         ENDIF
+         ENDDO
+  807    CONTINUE
+         DO k = klev, 1, -1
+         IF (rneb(i,k).GT.0.0) THEN
+            itop(i) = k
+            GOTO 808
+         ENDIF
+         ENDDO
+  808    CONTINUE
+      ENDIF
+  888 CONTINUE
+c
+      IF (imprim) THEN
+         nbtodo = 0
+         nbdone = 0
+         DO i = 1, klon
+            IF (afaire(i)) nbtodo = nbtodo + 1
+            IF (accompli(i)) nbdone = nbdone + 1
+         ENDDO
+         PRINT*, "nbTodo, nbDone=", nbtodo, nbdone
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE conkuo(dtime, paprs, pplay, t, q, conv_q,
+     s                  d_t, d_q, d_ql, rneb, 
+     s                  rain, snow, ibas, itop)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Schema de convection de type Kuo (1965).
+c        Cette version du code peut calculer le niveau de depart
+c N.B. version vectorielle (le 6 oct. 1997)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime               ! intervalle du temps (s)
+      REAL paprs(klon,klev+1)  ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)    ! pression au milieu de couche (Pa)
+      REAL t(klon,klev)        ! temperature (K)
+      REAL q(klon,klev)        ! humidite specifique
+      REAL conv_q(klon,klev)   ! taux de convergence humidite (g/g/s)
+c
+      REAL d_t(klon,klev)      ! incrementation temperature
+      REAL d_q(klon,klev)      ! incrementation humidite
+      REAL d_ql(klon,klev)     ! incrementation eau liquide
+      REAL rneb(klon,klev)     ! nebulosite
+      REAL rain(klon)          ! pluies (mm/s)
+      REAL snow(klon)          ! neige (mm/s)
+      INTEGER itop(klon)       ! niveau du sommet
+      INTEGER ibas(klon)       ! niveau du bas
+c
+      LOGICAL ldcum(klon)      ! convection existe
+      LOGICAL todo(klon)
+c
+c Quelsques options:
+c
+      LOGICAL calcfcl ! calculer le niveau de convection libre
+      PARAMETER (calcfcl=.TRUE.)
+      INTEGER ldepar ! niveau fixe de convection libre
+      PARAMETER (ldepar=4)
+      INTEGER opt_cld ! comment traiter l'eau liquide
+      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=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=1.0E-05)
+      LOGICAL new_deh ! nouvelle facon de calculer dH
+      PARAMETER (new_deh=.FALSE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      LOGICAL old_tau ! implique precipitation nulle
+      PARAMETER (old_tau=.FALSE.)
+      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.15, tomax=0.97)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      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:
+c
+      INTEGER nexpo
+      LOGICAL nuage(klon)
+      INTEGER i, k, kbmin, kbmax, khmax
+      REAL ztotal(klon,klev), zdeh(klon,klev)
+      REAL zgz(klon,klev)
+      REAL zqs(klon,klev)
+      REAL zdqs(klon,klev)
+      REAL ztemp(klon,klev)
+      REAL zpres(klon,klev)
+      REAL zconv(klon) ! convergence d'humidite
+      REAL zvirt(klon) ! convergence virtuelle d'humidite
+      REAL zfrac(klon) ! fraction convective
+      INTEGER kb(klon), kh(klon)
+c
+      REAL zcond(klon), zvapo(klon), zrapp(klon)
+      REAL zrfl(klon), zrfln, zqev, zqevt
+      REAL zdelta, zcvm5, zcor
+      REAL zvar
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c
+c Fonctions thermodynamiques
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'conkuo, calcfcl:', calcfcl
+         IF (.NOT.calcfcl) PRINT*, 'conkuo, ldepar:', ldepar
+         PRINT*, 'conkuo, opt_cld:', opt_cld
+         PRINT*, 'conkuo, evap_prec:', evap_prec
+         PRINT*, 'conkuo, new_deh:', new_deh
+         appel1er = .FALSE.
+      ENDIF
+c
+c Initialiser les sorties a zero
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer la vapeur d'eau saturante Qs et sa derive L/Cp * dQs/dT
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,k)))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)=R2ES*FOEEW(t(i,k),zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(t(i,k),zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (t(i,k).LT.t_coup) THEN
+              zqs(i,k) = qsats(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsats(t(i,k),zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(t(i,k))/pplay(i,k)
+              zdqs(i,k) = dqsatl(t(i,k),zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer gz (energie potentielle)
+c
+      DO i = 1, klon
+         zgz(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .                   * (paprs(i,1)-pplay(i,1))
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         zgz(i,k) = zgz(i,k-1)
+     .            + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                 * (pplay(i,k-1)-pplay(i,k))
+      ENDDO
+      ENDDO
+c
+c Calculer l'energie statique humide saturee (Cp*T + gz + L*Qs)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztotal(i,k) = RCPD*t(i,k) + RLVTT*zqs(i,k) + zgz(i,k)
+      ENDDO
+      ENDDO
+c
+c Determiner le niveau de depart et calculer la difference de
+c l'energie statique humide saturee (ztotal) entre la couche
+c de depart et chaque couche au-dessus.
+c
+      IF (calcfcl) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            zpres(i,k) = pplay(i,k)
+            ztemp(i,k) = t(i,k)
+         ENDDO
+         ENDDO
+         CALL kuofcl(ztemp, q, zgz, zpres, ldcum, kb)
+         DO i = 1, klon
+         IF (ldcum(i)) THEN
+            k = kb(i)
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDIF
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+         IF (ldcum(i) .AND. k.GE.(kb(i)+1)) THEN
+            IF (new_deh) THEN
+               zdeh(i,k) = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+            ELSE
+               zdeh(i,k) = zdeh(i,k-1)
+     .                   + RCPD * (t(i,k-1)-t(i,k))
+     .                   - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                        *(pplay(i,k-1)-pplay(i,k))
+     .                   + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+         ENDIF
+         ENDDO
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            k = ldepar
+            kb(i) = ldepar
+            ldcum(i) = .TRUE.
+            IF (new_deh) THEN
+            zdeh(i,k) = ztotal(i,k-1) - ztotal(i,k)
+            ELSE
+            zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .                - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .                + RLVTT*(zqs(i,k-1)-zqs(i,k))
+            ENDIF
+            zdeh(i,k) = zdeh(i,k) * 0.5
+         ENDDO
+         DO k = ldepar+1, klev
+         DO i = 1, klon
+         IF (new_deh) THEN
+             zdeh(i,k)  = zdeh(i,k-1) + (ztotal(i,k-1)-ztotal(i,k))
+         ELSE
+             zdeh(i,k) = zdeh(i,k-1)
+     .                 + RCPD * (t(i,k-1)-t(i,k))
+     .                 - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                      *(pplay(i,k-1)-pplay(i,k))
+     .                 + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c-----Chercher le sommet du nuage
+c-----Calculer la convergence de l'humidite (en kg/m**2 a un facteur
+c-----psolpa/RG pres) du bas jusqu'au sommet du nuage.
+c-----Calculer la convergence virtuelle pour que toute la maille 
+c-----deviennt nuageuse (du bas jusqu'au sommet du nuage)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (k.GE.kb(i) .AND. ldcum(i)) THEN
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i) = k
+            zconv(i)=zconv(i)+conv_q(i,k)*dtime
+     .                       *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         todo(i) = ldcum(i) .AND. kh(i).GT.kb(i) .AND. zconv(i).GT.0.0
+      ENDDO
+c
+      kbmin = klev
+      kbmax = 0
+      khmax = 0
+      DO i = 1, klon
+      IF (todo(i)) THEN
+         kbmin = MIN(kbmin,kb(i))
+         kbmax = MAX(kbmax,kb(i))
+         khmax = MAX(khmax,kh(i))
+      ENDIF
+      ENDDO
+c
+c-----Calculer la surface couverte par le nuage
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i), 1.0))
+      ENDIF
+      ENDDO
+c
+c-----Calculs essentiels:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      zcond(i) = 0.0
+      ENDIF
+      ENDDO
+      DO k = kbmin, khmax
+      DO i = 1, klon
+      IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+         zvar = zdeh(i,k)/(1.+zdqs(i,k))
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         zcond(i) = zcond(i) - d_q(i,k) *(paprs(i,k)-paprs(i,k+1))/RG
+         rneb(i,k) = zfrac(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (todo(i) .AND. zcond(i).LT.0.0) THEN
+         PRINT*, 'WARNING: cond. negative (Kuo) ',
+     .            i,kb(i),kh(i), zcond(i)
+         zcond(i) = 0.0
+         DO k = kb(i), kh(i)
+            d_t(i,k) = 0.0
+            d_q(i,k) = 0.0
+         ENDDO
+         todo(i) = .FALSE. ! effort totalement perdu
+      ENDIF
+      ENDDO
+c
+c=====
+c Une fois que la condensation a lieu, on doit construire un
+c "modele nuageux" pour partager la condensation entre l'eau
+c liquide nuageuse et la precipitation (leur rapport toliq
+c est calcule selon l'epaisseur nuageuse). Je suppose que
+c toliq=tomax quand l'epaisseur nuageuse est inferieure a dpmin,
+c et que toliq=tomin quand l'epaisseur depasse dpmax (interpolation
+c lineaire entre dpmin et dpmax).
+c=====
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      toliq(i) = tomax-((paprs(i,kb(i))-paprs(i,kh(i)+1))
+     .               /paprs(i,1)-dpmin)
+     .             *(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
+      ENDDO
+c=====
+c On doit aussi determiner la distribution verticale de
+c l'eau nuageuse. Plusieurs options sont proposees:
+c
+c (0) La condensation precipite integralement (toliq ne sera
+c     pas utilise).
+c (1) L'eau liquide est distribuee entre k1 et k2 et proportionnelle
+c     a la vapeur d'eau locale.
+c (2) Elle est distribuee entre k1 et k2 avec une valeur constante.
+c (3) Elle est seulement distribuee aux couches ou la vapeur d'eau
+c     est effectivement diminuee pendant le processus d'ajustement.
+c (4) Elle est en fonction (lineaire ou exponentielle) de la
+c     distance (epaisseur en pression) avec le niveau k1 (la couche
+c     k1 n'aura donc pas d'eau liquide).
+c=====
+c
+      IF (opt_cld.EQ.0) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zrfl(i) = zcond(i) / dtime
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.1) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de vapeur d'eau
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (q(i,k)+d_q(i,k))
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+            zrapp(i) = toliq(i) * zcond(i) / zvapo(i)
+            zrapp(i) = MAX(0.,MIN(1.,zrapp(i)))
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = zrapp(i) * (q(i,k)+d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.2) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) zvapo(i) = 0.0 ! quantite integrale de masse
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = toliq(i) * zcond(i) / zvapo(i)
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.3) THEN
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite de l'eau strictement condensee
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + MAX(0.0,-d_q(i,k))
+     .                    * (paprs(i,k)-paprs(i,k+1))/RG
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.kb(i) .AND. k.LE.kh(i) .AND.
+     .                     zvapo(i).GT.0.0) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * MAX(0.0,-d_q(i,k))
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE IF (opt_cld.EQ.4) THEN
+c
+         nexpo = 3
+ccc         nexpo = 1 ! distribution lineaire
+c
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zvapo(i) = 0.0 ! quantite integrale de masse (avec ponderation)
+         ENDIF
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            zvapo(i) = zvapo(i) + (paprs(i,k)-paprs(i,k+1)) / RG
+     .                    * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO k = kbmin, khmax
+         DO i = 1, klon
+         IF (todo(i) .AND. k.GE.(kb(i)+1) .AND. k.LE.kh(i)) THEN
+            d_ql(i,k) = d_ql(i,k) + toliq(i) * zcond(i) / zvapo(i)
+     .                            * (pplay(i,kb(i))-pplay(i,k))**nexpo
+         ENDIF
+         ENDDO
+         ENDDO
+         DO i = 1, klon
+         IF (todo(i)) THEN
+         zrfl(i) = (1.0-toliq(i)) * zcond(i) / dtime
+         ENDIF
+         ENDDO
+c
+      ELSE ! valeur non-prevue pour opt_cld
+c
+         PRINT*, "opt_cld est faux:", opt_cld
+         CALL abort
+c
+      ENDIF ! fin de opt_cld
+c
+c L'eau precipitante peut etre re-evaporee:
+c
+      IF (evap_prec .AND. kbmax.GE.2) THEN
+      DO k = kbmax, 1, -1
+      DO i = 1, klon
+      IF (todo(i) .AND. k.LE.(kb(i)-1) .AND. zrfl(i).GT.0.0) THEN
+         zqev = MAX (0.0, (zqs(i,k)-q(i,k))*zfrac(i) )
+         zqevt = coef_eva * (1.0-q(i,k)/zqs(i,k))*SQRT(zrfl(i))
+     .       * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*t(i,k)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                 /RG/dtime
+         d_q(i,k) = - (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         d_t(i,k) = (zrfln-zrfl(i))
+     .          * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .          * RLVTT/RCPD
+         zrfl(i) = zrfln
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c La temperature de la premiere couche determine la pluie ou la neige:
+c
+      DO i = 1, klon
+      IF (todo(i)) THEN
+      IF (t(i,1) .GT. RTT) THEN
+         rain(i) = rain(i) + zrfl(i)
+      ELSE
+         snow(i) = snow(i) + zrfl(i)
+      ENDIF
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE kuofcl(pt, pq, pg, pp, LDCUM, kcbot)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: calculer le niveau de convection libre
+c        (FCL: Free Convection Level)
+c======================================================================
+c Arguments:
+c pt---input-R- temperature (K)
+c pq---input-R- vapeur d'eau (kg/kg)
+c pg---input-R- geopotentiel (g*z ou z est en metre)
+c pp---input-R- pression (Pa)
+c
+c LDCUM---output-L- Y-t-il la convection
+c kcbot---output-I- Niveau du bas de la convection
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pt(klon,klev), pq(klon,klev), pg(klon,klev), pp(klon,klev)
+      INTEGER  kcbot(klon)
+      LOGICAL  LDCUM(klon)
+C
+      REAL ztu(klon,klev), zqu(klon,klev), zlu(klon,klev)
+      REAL zqold(klon), zbuo
+      INTEGER is, i, k
+c
+c klab=1: on est sous le nuage convectif
+c klab=2: le bas du nuage convectif
+c klab=0: autres couches
+      INTEGER klab(klon,klev)
+c
+c quand lflag=.true., on est sous le nuage, il faut donc appliquer
+c le processus d'elevation.
+      LOGICAL lflag(klon)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         ztu(i,k) = pt(i,k)
+         zqu(i,k) = pq(i,k)
+         zlu(i,k) = 0.0
+         klab(i,k) = 0
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,1)=1
+         kcbot(i)=2
+         LDCUM(i)=.FALSE.
+      ENDDO
+C
+      DO 290 k = 2, klev-1
+c
+      is=0
+      DO i = 1, klon
+         if (klab(i,k-1).EQ.1) is = is + 1
+         lflag(i) = .FALSE.
+         if (klab(i,k-1).EQ.1) lflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+c on eleve le parcel d'air selon l'adiabatique sec
+c
+      DO i = 1, klon
+      IF (lflag(i)) THEN
+         zqu(i,k) = zqu(i,k-1)
+         ztu(i,k) = ztu(i,k-1) + (pg(i,k-1)-pg(i,k))/RCPD
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k)=1
+         zqold(i) = zqu(i,k)
+      ENDIF
+      ENDDO
+c
+c on calcule la condensation eventuelle
+c
+      CALL adjtq(pp(1,k), ztu(1,k), zqu(1,k), lflag, 1)
+c
+c s'il y a la condensation et la "buoyancy" force est positive
+c c'est bien le bas de la tour de convection
+c
+      DO i=1, klon
+      IF(lflag(i).AND.zqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         zlu(i,k) = zlu(i,k)+zqold(i)-zqu(i,k)
+         zbuo = ztu(i,k)*(1.+RETV*zqu(i,k))-
+     .          pt(i,k)*(1.+RETV*pq(i,k))+0.5
+         IF (zbuo.GT.0.) THEN
+            kcbot(i) = k
+            LDCUM(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+C
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE adjtq(pp, pt, pq, LDFLAG, KCALL)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19940927
+c            adaptation du code de Tiedtke du ECMWF
+c Objet: ajustement entre T et Q
+c======================================================================
+c Arguments:
+c pp---input-R- pression (Pa)
+c pt---input/output-R- temperature (K)
+c pq---input/output-R- vapeur d'eau (kg/kg)
+c======================================================================
+C TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+C
+C NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+C        KCALL=0    ENV. T AND QS IN*CUINI*
+C        KCALL=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL  ldflag(klon)
+      INTEGER KCALL
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zcond(klon), zcond1
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor, zdqsat
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+C
+      DO 210 i=1, klon
+      IF (LDFLAG(i)) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond(i)=(pq(i)-zqsat) / (1. + zdqsat)
+         IF(KCALL.EQ.1) zcond(i)=MAX(zcond(i),0.)
+         IF(KCALL.EQ.2) zcond(i)=MIN(zcond(i),0.)
+         pt(i)=pt(i)+zldcp*zcond(i)
+         pq(i)=pq(i)-zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i=1, klon
+         if (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF(is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(LDFLAG(i).AND.zcond(i).NE.0.) THEN
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i)))
+         zldcp = RLVTT*(1.-zdelta) + zdelta*RLSTT
+         zldcp = zldcp / RCPD/(1.0+RVTMP2*pq(i))
+         IF (thermcep) THEN
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 / RCPD/(1.0+RVTMP2*pq(i))
+           zqsat=R2ES*FOEEW (pt(i), zdelta) / pp(i)
+           zqsat=MIN(0.5,zqsat)
+           zcor=1./(1.-RETV  *zqsat)
+           zqsat=zqsat*zcor
+           zdqsat = FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor)
+         ELSE
+           IF (pt(i).LT.t_coup) THEN
+              zqsat = qsats(pt(i))/pp(i)
+              zdqsat = dqsats(pt(i),zqsat)
+           ELSE
+              zqsat = qsatl(pt(i))/pp(i)
+              zdqsat = dqsatl(pt(i),zqsat)
+           ENDIF
+         ENDIF
+         zcond1=(pq(i)-zqsat) / (1.+zdqsat)
+         pt(i)=pt(i)+zldcp*zcond1
+         pq(i)=pq(i)-zcond1
+      END IF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE fiajh(dtime, paprs, pplay, t, q,
+     .                 d_t, d_q, d_ql, rneb,
+     .                 rain, snow, ibas, itop)
+      IMPLICIT NONE
+c
+c Ajustement humide (Schema de convection de Manabe)
+C.
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL dtime        ! intervalle du temps (s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+c
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL d_q(klon,klev) ! incrementation pour vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+c
+      REAL rain(klon)    ! variable non utilisee
+      REAL snow(klon)    ! variable non utilisee
+      INTEGER ibas(klon) ! variable non utilisee
+      INTEGER itop(klon) ! variable non utilisee
+
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+      REAL seuil_vap
+      PARAMETER (seuil_vap=1.0E-10)
+c
+c Variables locales:
+c 
+      INTEGER i, k
+      INTEGER k1, k1p, k2, k2p
+      LOGICAL itest(klon)
+      REAL delta_q(klon, klev)
+      REAL cp_new_t(klev)
+      REAL cp_delta_t(klev)
+      REAL new_qb(klev)
+      REAL v_cptj(klev), v_cptjk1, v_ssig
+      REAL v_cptt(klon,klev), v_p, v_t
+      REAL v_qs(klon,klev), v_qsd(klon,klev)
+      REAL zq1(klon), zq2(klon)
+      REAL gamcpdz(klon,2:klev)
+      REAL zdp, zdpm
+c
+      REAL zsat ! sur-saturation
+      REAL zflo ! flotabilite
+c
+      REAL local_q(klon,klev),local_t(klon,klev)
+c
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         local_q(i,k) = q(i,k)
+         local_t(i,k) = t(i,k)
+         rneb(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         ibas(i) = 0
+         itop(i) = 0
+      ENDDO
+c
+c Calculer v_qs et v_qsd:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+c
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer Gamma * Cp * dz: (gamm est le gradient critique)
+c
+      DO k = 2, klev
+      DO i = 1, klon
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zdpm = paprs(i,k-1)-paprs(i,k)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) * 
+     .                      (v_cptt(i,k-1)*zdpm + v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) * 
+     .                      (v_qs(i,k-1)*zdpm + v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+
+     .                        v_qsd(i,k)*zdp)/(zdpm+zdp) )
+      ENDDO
+      ENDDO
+C
+C------------------------------------ modification des profils instables
+      DO 9999 i = 1, klon
+      itest(i) = .FALSE.
+C
+      k1 = 0
+      k2 = 1
+C
+  810 CONTINUE ! chercher k1, le bas de la colonne
+      k2 = k2 + 1
+      IF (k2 .GT. klev) GOTO 9999
+      zflo = v_cptt(i,k2-1) - v_cptt(i,k2) - gamcpdz(i,k2)
+      zsat=(local_q(i,k2-1)-v_qs(i,k2-1))*(paprs(i,k2-1)-paprs(i,k2))
+     .    +(local_q(i,k2)-v_qs(i,k2))*(paprs(i,k2)-paprs(i,k2+1))
+      IF ( zflo.LE.0.0 .OR. zsat.LE.0.0 ) GOTO 810
+      k1 = k2 - 1
+      itest(i) = .TRUE.
+C
+  820 CONTINUE ! chercher k2, le haut de la colonne
+      IF (k2 .EQ. klev) GOTO 821
+      k2p = k2 + 1
+      zsat=zsat +(paprs(i,k2p)-paprs(i,k2p+1))
+     .          *(local_q(i,k2p)-v_qs(i,k2p))
+      zflo = v_cptt(i,k2p-1) - v_cptt(i,k2p) - gamcpdz(i,k2p)
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 821
+      k2 = k2p
+      GOTO 820
+  821 CONTINUE
+C
+C------------------------------------------------------ ajustement local
+  830 CONTINUE ! ajustement proprement dit
+      v_cptj(k1) = 0.0
+      zdp = paprs(i,k1)-paprs(i,k1+1)
+      v_cptjk1 = ( (1.0+v_qsd(i,k1))*(v_cptt(i,k1)+v_cptj(k1))
+     .               + RLVTT*(local_q(i,k1)-v_qs(i,k1)) ) * zdp
+      v_ssig = zdp * (1.0+v_qsd(i,k1))
+C
+      k1p = k1 + 1
+      DO k = k1p, k2
+         zdp = paprs(i,k)-paprs(i,k+1)
+         v_cptj(k) = v_cptj(k-1) + gamcpdz(i,k)
+         v_cptjk1 = v_cptjk1 + zdp
+     .             * ( (1.0+v_qsd(i, k))*(v_cptt(i,k)+v_cptj(k))
+     .               + RLVTT*(local_q(i,k)-v_qs(i,k)) )
+         v_ssig = v_ssig + zdp *(1.0+v_qsd(i,k))
+      ENDDO
+C
+      DO k = k1, k2
+         cp_new_t(k) = v_cptjk1/v_ssig - v_cptj(k)
+         cp_delta_t(k) = cp_new_t(k) - v_cptt(i,k)
+         new_qb(k) = v_qs(i,k) + v_qsd(i,k)*cp_delta_t(k)/RLVTT
+         local_q(i,k) = new_qb(k)
+         local_t(i,k) = cp_new_t(k) / RCPD
+      ENDDO
+C
+C--------------------------------------------------- sondage vers le bas
+C              -- on redefinit les variables prognostiques dans
+C              -- la colonne qui vient d'etre ajustee
+C
+      DO k = k1, k2
+         v_cptt(i,k) = RCPD * local_t(i,k)
+         v_t = local_t(i,k)
+         v_p = pplay(i,k)
+C
+         IF (thermcep) THEN
+            zdelta=MAX(0.,SIGN(1.,RTT-v_t))
+            zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+            zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*local_q(i,k))
+            v_qs(i,k)= R2ES * FOEEW(v_t,zdelta)/v_p
+            v_qs(i,k)=MIN(0.5,v_qs(i,k))
+            zcor=1./(1.-RETV*v_qs(i,k))
+            v_qs(i,k)=v_qs(i,k)*zcor
+            v_qsd(i,k) =FOEDE(v_t,zdelta,zcvm5,v_qs(i,k),zcor)
+         ELSE
+           IF (v_t.LT.t_coup) THEN
+              v_qs(i,k) = qsats(v_t) / v_p
+              v_qsd(i,k) = dqsats(v_t,v_qs(i,k))
+           ELSE
+              v_qs(i,k) = qsatl(v_t) / v_p
+              v_qsd(i,k) = dqsatl(v_t,v_qs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      DO k = 2, klev
+         zdpm = paprs(i,k-1) - paprs(i,k)
+         zdp = paprs(i,k) - paprs(i,k+1)
+         gamcpdz(i,k) = ( ( RD/RCPD /(zdpm+zdp) *
+     .                      (v_cptt(i,k-1)*zdpm+v_cptt(i,k)*zdp)
+     .                     +RLVTT /(zdpm+zdp) *
+     .                      (v_qs(i,k-1)*zdpm+v_qs(i,k)*zdp)
+     .                    )* (pplay(i,k-1)-pplay(i,k)) / paprs(i,k) )
+     .                / (1.0+(v_qsd(i,k-1)*zdpm+v_qsd(i,k)*zdp)
+     .                      /(zdpm+zdp) )
+      ENDDO
+C
+C Verifier si l'on peut etendre la colonne vers le bas
+C
+      IF (k1 .EQ. 1) GOTO 841 ! extension echouee
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      zsat=(local_q(i,k1-1)-v_qs(i,k1-1))*(paprs(i,k1-1)-paprs(i,k1))
+     .   + (local_q(i,k1)-v_qs(i,k1))*(paprs(i,k1)-paprs(i,k1+1))
+      IF (zflo.LE.0.0 .OR. zsat.LE.0.0) GOTO 841 ! extension echouee
+C
+  840 CONTINUE
+      k1 = k1 - 1
+      IF (k1 .EQ. 1) GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      zsat = zsat + (local_q(i,k1-1)-v_qs(i,k1-1))
+     .             *(paprs(i,k1-1)-paprs(i,k1))
+      zflo = v_cptt(i,k1-1) - v_cptt(i,k1) - gamcpdz(i,k1)
+      IF (zflo.GT.0.0 .AND. zsat.GT.0.0) THEN
+         GOTO 840
+      ELSE
+         GOTO 830 ! GOTO 820 (a tester, Z.X.Li, mars 1995)
+      ENDIF
+  841 CONTINUE
+C
+      GOTO 810 ! chercher d'autres blocks en haut
+C
+ 9999 CONTINUE ! boucle sur tous les points
+C-----------------------------------------------------------------------
+c
+c Determiner la fraction nuageuse (hypothese: la nebulosite a lieu
+c a l'endroit ou la vapeur d'eau est diminuee par l'ajustement):
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         delta_q(i,k) = local_q(i,k) - q(i,k)
+         IF (delta_q(i,k).LT.0.) rneb(i,k)  = 1.0
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Distribuer l'eau condensee en eau liquide nuageuse (hypothese:
+c l'eau liquide est distribuee aux endroits ou la vapeur d'eau
+c diminue et d'une maniere proportionnelle a cet diminution):
+c
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         zdp = paprs(i,k)-paprs(i,k+1)
+         zq1(i) = zq1(i) - delta_q(i,k) * zdp
+         zq2(i) = zq2(i) - MIN(0.0, delta_q(i,k)) * zdp
+         ENDIF
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         IF (itest(i)) THEN
+         IF (zq2(i).NE.0.0)
+     .      d_ql(i,k) = - MIN(0.0,delta_q(i,k))*zq1(i)/zq2(i)
+         ENDIF
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+          local_q(i, k) = MAX(local_q(i, k), seuil_vap)
+      ENDDO
+      ENDDO
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = local_t(i,k) - t(i,k)
+         d_q(i,k) = local_q(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE fiajc(dtime,paprs,pplay,
+     .                 t, q,conv_q,
+     .                 d_t, d_q, d_ql,rneb,
+     .                 rain, snow, ibas, itop)
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Options:
+c
+      INTEGER plb ! niveau de depart pour la convection
+      PARAMETER (plb=4)
+c
+c Mystere: cette option n'est pas innocente pour les resultats !
+c Qui peut resoudre ce mystere ? (Z.X.Li mars 1995)
+      LOGICAL vector ! calcul vectorise
+      PARAMETER (vector=.FALSE.)
+c
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Arguments:
+c
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL t(klon,klev) ! temperature (K)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev) ! pression au milieu de couche (Pa)
+      REAL dtime ! intervalle du temps (s)
+      REAL conv_q(klon,klev) ! taux de convergence de l'humidite
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL d_q(klon,klev) ! incrementaion pour la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation pour l'eau liquide
+      REAL d_t(klon,klev) ! incrementation pour la temperature
+      REAL rain(klon) ! variable non-utilisee
+      REAL snow(klon) ! variable non-utilisee
+      INTEGER itop(klon) ! variable non-utilisee
+      INTEGER ibas(klon) ! variable non-utilisee
+c
+      INTEGER kh(klon), i, k
+      LOGICAL nuage(klon), test(klon,klev)
+      REAL zconv(klon), zdeh(klon,klev), zvirt(klon)
+      REAL zdqs(klon,klev), zqs(klon,klev)
+      REAL ztt, zvar, zfrac(klon)
+      REAL zq1(klon), zq2(klon)
+      REAL zdelta, zcor, zcvm5
+C
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialiser les sorties:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+          rneb(i,k) = 0.0
+          d_ql(i,k) = 0.0
+          d_t(i,k) = 0.0
+          d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         itop(i) = 0
+         ibas(i) = 0
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Calculer Qs et L/Cp * dQs/dT:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         ztt = t(i,k)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-ztt))
+           zcvm5=R5LES*RLVTT*(1.-zdelta) + zdelta*R5IES*RLSTT
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*q(i,k))
+           zqs(i,k)= R2ES*FOEEW(ztt,zdelta)/pplay(i,k)
+           zqs(i,k)=MIN(0.5,zqs(i,k))
+           zcor=1./(1.-RETV*zqs(i,k))
+           zqs(i,k)=zqs(i,k)*zcor
+           zdqs(i,k) =FOEDE(ztt,zdelta,zcvm5,zqs(i,k),zcor)
+         ELSE
+           IF (ztt .LT. t_coup) THEN
+              zqs(i,k) = qsats(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsats(ztt,zqs(i,k))
+           ELSE
+              zqs(i,k) = qsatl(ztt) / pplay(i,k)
+              zdqs(i,k) = dqsatl(ztt,zqs(i,k))
+           ENDIF
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Determiner la difference de l'energie totale saturee:
+c
+      DO i = 1, klon
+         k = plb
+         zdeh(i,k) = RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+         zdeh(i,k) = zdeh(i,k) * 0.5 ! on prend la moitie
+      ENDDO
+      DO k = plb+1, klev
+      DO i = 1, klon
+      zdeh(i,k) = zdeh(i,k-1)
+     .             + RCPD * (t(i,k-1)-t(i,k))
+     .             - RD *0.5*(t(i,k-1)+t(i,k))/paprs(i,k)
+     .                  *(pplay(i,k-1)-pplay(i,k))
+     .             + RLVTT*(zqs(i,k-1)-zqs(i,k))
+      ENDDO
+      ENDDO
+c
+c Determiner le sommet du nuage selon l'instabilite
+c Calculer les convergences d'humidite (reelle et virtuelle)
+c
+      DO i = 1, klon
+         nuage(i) = .TRUE.
+         zconv(i) = 0.0
+         zvirt(i) = 0.0
+         kh(i) = -999
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+         nuage(i) = nuage(i) .AND. zdeh(i,k).GT.0.0
+         IF (nuage(i)) THEN
+            kh(i)  = k
+            zconv(i) = zconv(i)+conv_q(i,k)*dtime
+     .                         *(paprs(i,k)-paprs(i,k+1))
+            zvirt(i)=zvirt(i)+(zdeh(i,k)/RLVTT+zqs(i,k)-q(i,k))
+     .                       *(paprs(i,k)-paprs(i,k+1))
+         ENDIF
+      ENDDO
+      ENDDO
+c
+      IF (vector) THEN
+c
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (k.LE.kh(i) .AND. kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+         test(i,k) = .TRUE.
+         zfrac(i) = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+      ELSE
+         test(i,k) = .FALSE.
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+         d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .            - conv_q(i,k)*dtime
+         d_t(i,k) = zvar * zfrac(i) / RCPD
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+      ENDDO
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+         zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+         zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                   * (paprs(i,k)-paprs(i,k+1))
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO k = plb, klev
+      DO i = 1, klon
+      IF (test(i,k)) THEN
+         IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      ELSE ! (.NOT. vector)
+c
+      DO 999 i = 1, klon
+      IF (kh(i).GT.plb .AND. zconv(i).GT.0.0) THEN
+ccc         IF (kh(i).LE.plb) GOTO 999 ! il n'y a pas d'instabilite
+ccc         IF (zconv(i).LE.0.0) GOTO 999 ! convergence insuffisante
+         zfrac(i)  = MAX(0.0,MIN(zconv(i)/zvirt(i),1.0))
+         DO k = plb, kh(i)
+            zvar = zdeh(i,k)/(1.0+zdqs(i,k))
+            d_q(i,k) = (zvar*zdqs(i,k)/RLVTT+zqs(i,k)-q(i,k))*zfrac(i)
+     .               - conv_q(i,k)*dtime
+            d_t(i,k) = zvar * zfrac(i) / RCPD
+         ENDDO
+c
+         zq1(i) = 0.0
+         zq2(i) = 0.0
+         DO k = plb, kh(i)
+            IF (d_q(i,k).LT.0.0) rneb(i,k) = zfrac(i)
+            zq1(i) = zq1(i) - d_q(i,k) * (paprs(i,k)-paprs(i,k+1))
+            zq2(i) = zq2(i) - MIN(0.0, d_q(i,k))
+     .                      * (paprs(i,k)-paprs(i,k+1))
+         ENDDO
+         DO k = plb, kh(i)
+            IF(zq2(i).NE.0.)d_ql(i,k)=-MIN(0.0,d_q(i,k))*zq1(i)/zq2(i)
+         ENDDO
+      ENDIF
+  999 CONTINUE
+c
+      ENDIF ! fin de teste sur vector
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect1.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect1.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect1.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/convect2.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect2.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect2.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/convect3.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect3.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/convect3.F	(revision 428)
@@ -0,0 +1,1402 @@
+c $Header$
+      SUBROUTINE CONVECT3	
+     *    (DTIME,EPMAX,ok_adj,
+     *     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,
+cccc     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR)
+     *     DTVPDT1,DTVPDQ1,DPLCLDT,DPLCLDR,   ! sbl
+     *     FT2,FR2,FU2,FV2,WD,QCOND,QCONDC)   ! sbl
+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)
+      REAL DELTAC              ! cld
+      PARAMETER (DELTAC=0.01)  ! cld
+
+      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 FT2(ND),FR2(ND),FU2(ND),FV2(ND) ! added sbl
+      REAL U1(ND),V1(ND) ! added sbl
+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
+      REAL WD, BETAD ! for gust factor (sb)
+      REAL QCONDC(ND)  ! interface cld param (sb)
+      REAL QCOND(ND),NQCOND(NA),WA(NA),MAA(NA),SIGA(NA),AXC(NA) ! cld
+C
+      LOGICAL ICE_CONV,ok_adj
+      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
+
+         FT2(I)=0.0
+         FR2(I)=0.0
+         FU2(I)=0.0
+         FV2(I)=0.0
+
+         DO 4 J=1,NTRA
+          FTRA(I,J)=0.0
+    4    CONTINUE
+
+         QCONDC(I)=0.0  ! cld
+         QCOND(I)=0.0   ! cld
+         NQCOND(I)=0.0  ! cld
+
+         T(I)=T1(I)
+         RR(I)=R1(I)
+         U1(I)=U(I) ! added sbl
+         V1(I)=V(I) ! added sbl
+    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
+      WD=0.0 ! sb
+      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:
+c     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!      NOPT=1 ! sbl
+C
+C     ***            PERFORM DRY ADIABATIC ADJUSTMENT            ***
+C
+C     ***  DO NOT BYPASS THIS EVEN IF THE CALLING PROGRAM HAS A  ***
+C     ***                BOUNDARY LAYER SCHEME !!!               ***
+C
+      IF (ok_adj) THEN ! added sbl
+
+      DO 30 I=NL-1,1,-1
+         JN=0
+         DO 10 J=I+1,NL
+   10    IF(TH(J).LT.TH(I))JN=J
+         IF(JN.EQ.0)GOTO 30
+         AHM=0.0
+         RM=0.0
+         UM=0.0
+         VM=0.0
+         DO K=1,NTRA
+          TRATM(K)=0.0
+         END DO
+         DO 15 J=I,JN
+          AHM=AHM+(CPD*(1.-RR(J))+RR(J)*CPV)*T(J)*(PH(J)-PH(J+1))
+          RM=RM+RR(J)*(PH(J)-PH(J+1))
+          UM=UM+U(J)*(PH(J)-PH(J+1))
+          VM=VM+V(J)*(PH(J)-PH(J+1))
+          DO K=1,NTRA
+           TRATM(K)=TRATM(K)+TRA(J,K)*(PH(J)-PH(J+1))
+          END DO
+   15    CONTINUE
+         DPHINV=1./(PH(I)-PH(JN+1))
+         RM=RM*DPHINV
+         UM=UM*DPHINV
+         VM=VM*DPHINV
+         DO K=1,NTRA
+          TRATM(K)=TRATM(K)*DPHINV
+         END DO
+         A2=0.0
+         DO 20 J=I,JN
+            RR(J)=RM
+          U(J)=UM
+          V(J)=VM
+          DO K=1,NTRA
+           TRA(J,K)=TRATM(K)
+          END DO
+            RDCP=(RD*(1.-RR(J))+RR(J)*RV)/ (CPD*(1.-RR(J))+RR(J)*CPV)
+            X=(0.001*P(J))**RDCP
+            T(J)=X
+            A2=A2+(CPD*(1.-RR(J))+RR(J)*CPV)*X*(PH(J)-PH(J+1))
+   20    CONTINUE
+         DO 25 J=I,JN
+            TH(J)=AHM/A2
+            T(J)=T(J)*TH(J)
+   25    CONTINUE
+   30 CONTINUE
+
+      ENDIF ! added sbl
+C
+C   ***   RESET INPUT ARRAYS IF ok_adj 0   ***
+C
+      IF (ok_adj)THEN
+         DO 35 I=1,ND
+
+           FT2(I)=(T(I)-T1(I))/DELT  ! sbl
+           FR2(I)=(RR(I)-R1(I))/DELT  ! sbl
+           FU2(I)=(U(I)-U1(I))/DELT  ! sbl
+           FV2(I)=(V(I)-V1(I))/DELT  ! sbl
+
+c!            T1(I)=T(I)      ! commente sbl
+c!            R1(I)=RR(I)     ! commente sbl
+   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
+c test sb:
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c@      write(*,*) 'plcl,dpbas,tvpbas,tvbas,tvp(icb),tvp(icb1)
+c@     :             ,tv(icb),tv(icb1)'
+c@      write(*,*) plcl,dpbase,tvpbase,tvbase,tvp(icb)
+c@     L          ,tvp(icb+1),tv(icb),tv(icb+1)
+c@      write(*,*) '++++++++++++++++++++++++++++++++++++++++'
+c fin test sb
+      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 test sb:
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c@      write(*,*) 'icb,icbs,inb,buoybase:'
+c@      write(*,*) icb,icb+1,inb,buoybase
+c@      write(*,*) 'k,tvp,tv,tp,buoy,ep: '
+c@      do k=1,nl
+c@      write(*,*) k,tvp(k),tv(k),tp(k),buoy(k),ep(k)
+c@      enddo
+c@      write(*,*) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'
+c fin test sb
+
+
+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
+c test sb:
+c@       write(*,*) '############################################'
+c@         write(*,*) 'cape,rrd,buoy,deltap,p,pbase,ph:'
+c@     :     ,cape,rd,buoy(i-1),deltap,p(i-1),pbase,ph(i)
+c@       write(*,*) '############################################'
+
+c fin test sb
+         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)
+
+c --------- test sb:
+c       write(*,*) '############################################'
+c       write(*,*) 'k,amu,buoy(k-1),deltap,w,beta,fac,cape,w0(k)'
+c       write(*,*) i,amu,buoy(i-1),deltap
+c     :           ,w,beta,fac,cape,w0(i)
+c       write(*,*) '############################################'
+c ---------
+
+         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--- test sb:
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c@       write(*,*) 'inb,m(inb),ment(inb,inb),sigij(inb,inb):'
+c@       write(*,*) inb,m(inb),ment(inb,inb),sigij(inb,inb)
+c@       write(*,*) '^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^'
+c---
+
+ 
+ 
+ 
+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
+
+c sb  ***  Calculate downdraft velocity scale and surface temperature and  ***
+c sb  ***                    water vapor fluctuations                      ***
+c sb		(inspire de convect 4.3)
+
+c       BETAD=10.0         
+       BETAD=5.0         
+       WD=BETAD*ABS(MP(ICB))*0.01*RD*T(ICB)/(SIGD*P(ICB))
+
+  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))*
+Ccorrection bug conservation eau
+C     1    DPINV+SIGD*0.5*(EVAP(1)+EVAP(2))
+     1    DPINV+SIGD*EVAP(1)
+        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))
+C (saturated updrafts resulting from mixing)      ! cld   
+         QCOND(I)=QCOND(I)+(ELIJ(K,I)-AWAT)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+         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
+C (saturated downdrafts resulting from mixing)    ! cld
+        DO K=I+1,INB                              ! cld
+         QCOND(I)=QCOND(I)+ELIJ(K,I)              ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDDO                                     ! cld
+C (particular case: no detraining level is found) ! cld
+        IF (NENT(I).EQ.0) THEN                    ! cld
+         QCOND(I)=QCOND(I)+(1-EP(I))*CLW(I)       ! cld
+         NQCOND(I)=NQCOND(I)+1.                   ! cld
+        ENDIF                                     ! cld
+        IF (NQCOND(I).NE.0.) THEN                 ! cld
+         QCOND(I)=QCOND(I)/NQCOND(I)              ! cld
+        ENDIF                                     ! cld
+  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
+c test sb:
+c@      write(*,*) '--------------------------------------------'
+c@      write(*,*) 'inb,ft,hp,h,t,rr,qent,ment,water,waterp,wt,mp,b'
+c@      write(*,*) inb,ft(inb),hp(inb),h(inb)
+c@     :   ,t(inb),rr(inb),qent(inb,inb)
+c@     :   ,ment(inb,inb),water(inb)
+c@     :   ,water(inb+1),wt(inb),mp(inb),b(inb)
+c@      write(*,*) '--------------------------------------------'
+c fin test sb:
+
+      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
+C   *** Diagnose the in-cloud mixing ratio   ***              ! cld
+C   ***           of condensed water         ***              ! cld
+C                                                             ! cld
+       DO I=1,ND                                              ! cld
+        MAA(I)=0.0                                            ! cld
+        WA(I)=0.0                                             ! cld
+        SIGA(I)=0.0                                           ! cld
+       ENDDO                                                  ! cld
+       DO I=NK,INB                                            ! cld
+       DO K=I+1,INB+1                                         ! cld
+        MAA(I)=MAA(I)+M(K)                                    ! cld
+       ENDDO                                                  ! cld
+       ENDDO                                                  ! cld
+       DO I=ICB,INB-1                                         ! cld
+        AXC(I)=0.                                             ! cld
+        DO J=ICB,I                                            ! cld
+         AXC(I)=AXC(I)+RD*(TVP(J)-TV(J))*(PH(J)-PH(J+1))/P(J) ! cld
+        ENDDO                                                 ! cld
+        IF (AXC(I).GT.0.0) THEN                               ! cld
+         WA(I)=SQRT(2.*AXC(I))                                ! cld
+        ENDIF                                                 ! cld
+       ENDDO                                                  ! cld
+       DO I=1,NL                                              ! cld
+        IF (WA(I).GT.0.0)                                     ! cld
+     1    SIGA(I)=MAA(I)/WA(I)*RD*TVP(I)/P(I)/100./DELTAC     ! cld
+        SIGA(I) = MIN(SIGA(I),1.0)                            ! cld
+        QCONDC(I)=SIGA(I)*CLW(I)*(1.-EP(I))                   ! cld
+     1          + (1.-SIGA(I))*QCOND(I)                       ! cld
+       ENDDO                                                  ! cld
+
+
+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/IPSL-CM4_v1x1/libf/phylmd/cv3_routines.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv3_routines.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv3_routines.F	(revision 428)
@@ -0,0 +1,3027 @@
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+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
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+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
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cvparam3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+      epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          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)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 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
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(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
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        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
+
+      return
+      end
+
+      SUBROUTINE cv3_feed(len,nd,t,q,qs,p,ph,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cvparam3.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+
+c@ !-------------------------------------------------------------------
+c@ ! --- Find level of minimum moist static energy
+c@ ! --- If level of minimum moist static energy coincides with
+c@ ! --- or is lower than minimum allowable parcel origin level,
+c@ ! --- set iflag to 6.
+c@ !-------------------------------------------------------------------
+c@ 
+c@       do 180 i=1,len
+c@        work(i)=1.0e12
+c@        ihmin(i)=nl
+c@  180  continue
+c@       do 200 k=2,nlp
+c@         do 190 i=1,len
+c@          if((hm(i,k).lt.work(i)).and.
+c@      &      (hm(i,k).lt.hm(i,k-1)))then
+c@            work(i)=hm(i,k)
+c@            ihmin(i)=k
+c@          endif
+c@  190    continue
+c@  200  continue
+c@       do 210 i=1,len
+c@         ihmin(i)=min(ihmin(i),nlm)
+c@         if(ihmin(i).le.minorig)then
+c@           iflag(i)=6
+c@         endif
+c@  210  continue
+c@ c
+c@ !-------------------------------------------------------------------
+c@ ! --- Find that model level below the level of minimum moist static
+c@ ! --- energy that has the maximum value of moist static energy
+c@ !-------------------------------------------------------------------
+c@  
+c@       do 220 i=1,len
+c@        work(i)=hm(i,minorig)
+c@        nk(i)=minorig
+c@  220  continue
+c@       do 240 k=minorig+1,nl
+c@         do 230 i=1,len
+c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+c@            work(i)=hm(i,k)
+c@            nk(i)=k
+c@          endif
+c@  230     continue
+c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    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      )     )
+c@      &       .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)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        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)
+c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        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
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- 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))
+c ori        ticb(i)=t(i,icb(i))
+c ori        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
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp
+     o                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cvparam3.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+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
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        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)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      do 121 j=1,ntra
+ccccc      do 111 k=1,nl+1
+      do 111 k=1,nd
+       nn=0
+      do 101 i=1,len
+      if(iflag1(i).eq.0)then
+       nn=nn+1
+       tra(nn,k,j)=tra1(i,k,j)
+      endif
+ 101  continue
+ 111  continue
+ 121  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(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)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c outputs:
+      integer inb(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real buoy(nloc,nd)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- 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)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(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
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       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
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            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
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c===================================================================== 
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+       buoy(icb(i),k)=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 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
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      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
+
+        return
+        end
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+c -------------------------------------------------------
+      
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  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 -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sij(nloc,na,na), elij(nloc,na,na)
+      real traent(nloc,nd,nd,ntra) 
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+      do k=1,ntra
+       do j=1,nd  ! instead nlp
+        do i=1,nd ! instead nlp
+         do il=1,ncum
+            traent(il,i,j,k)=tra(il,j,k)
+         enddo
+        enddo
+       enddo
+      enddo
+
+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 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+       do k=1,ntra
+        do j=minorig,nl
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+          endif
+         enddo
+        enddo
+       enddo
+
+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
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+      sij(il,i,i)=1.0
+      end if
+ 740  continue
+ 750  continue
+ 
+      do j=1,ntra
+       do i=minorig+1,nl
+        do il=1,ncum
+         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+          traent(il,i,i,j)=tra(il,nk(il),j)
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+      call zilch(asum,ncum*nd)
+      call zilch(bsum,ncum*nd)
+      call zilch(csum,ncum*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+        sij(il,i,i)=1.0
+       endif
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+         traent(il,i,i,j)=tra(il,nk(il),j)
+        endif
+       enddo
+      enddo
+
+789   continue
+      
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl
+     :              ,mp,rp,up,vp,trap,wt,water,evap,b)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+        do k=1,ntra
+         do i=1,nd
+          do il=1,ncum
+           trap(il,i,k)=tra(il,i,k)
+          enddo
+         enddo
+        enddo
+
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,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(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))
+     :                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+c
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+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(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,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(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +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(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+      do j=1,ntra
+      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+       do j=1,ntra
+       trap(il,i,j)=trap(il,i+1,j)
+       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra 
+     :                    ,icb,inb,delt
+     :                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b
+     :                    ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                    ,tv,tvp
+     :                    ,iflag,precip,ft,fr,fu,fv,ftra
+     :                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam3.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+      do j=1,ntra
+       do i=1,nd
+        do il=1,ncum
+          ftra(il,i,j)=0.0
+        enddo
+       enddo 
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)
+     :                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)
+     :-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if (cvflag_grav) then
+         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+        else
+         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+        endif
+       enddo
+      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+      do k=1,ntra
+       do j=2,nl
+        do il=1,ncum
+         if (j.le.inb(il)) then
+
+          if (cvflag_grav) then
+           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+     :                *(traent(il,j,1,k)-tra(il,1,k))
+          else
+           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+     :                *(traent(il,j,1,k)-tra(il,1,k))
+          endif
+
+         endif
+        enddo
+       enddo
+      enddo
+
+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,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+      do k=1,ntra
+       do il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+         if (cvflag_grav) then
+           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+         else
+           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+         endif
+        endif
+       enddo
+      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+      do j=1,ntra
+       do k=1,i-1
+        do il=1,ncum
+         if (i.le.inb(il)) then
+          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+          cpinv=1.0/cpn(il,i)
+          if (cvflag_grav) then
+           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+     :        *(traent(il,k,i,j)-tra(il,i,j))
+          else
+           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+     :        *(traent(il,k,i,j)-tra(il,i,j))
+          endif
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+      do j=1,ntra
+       do k=i,nl+1
+        do il=1,ncum
+         if (i.le.inb(il) .and. k.le.inb(il)) then
+          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+          cpinv=1.0/cpn(il,i)
+          if (cvflag_grav) then
+           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+     :         *(traent(il,k,i,j)-tra(il,i,j))
+          else
+           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+     :             *(traent(il,k,i,j)-tra(il,i,j))
+          endif
+         endif ! i and k
+        enddo
+       enddo
+      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+      do j=1,ntra
+       do il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+         else
+          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+         endif
+        endif ! i
+       enddo
+      enddo 
+
+
+500   continue
+
+
+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
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+      do j=1,ntra
+       do il=1,ncum
+        ex=0.1*ment(il,inb(il),inb(il)) 
+     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+       enddo
+      enddo
+
+c
+c   ***    homoginize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do il=1,ncum
+         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!     
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      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
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 il=1,ncum
+        rdcp=(rrd*(1.-rr(il,i))-rr(il,i)*rrv)
+     :        /(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
+        tls(il,i)=t(il,i)*(1000.0/p(il,i))**rdcp
+        tps(il,i)=tp(il,i)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                               ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end
+
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,iflag1
+     :         ,precip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :                               )
+      implicit none
+
+#include "cvparam3.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            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)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+        do 2100 j=1,ntra
+c oct3         do 2110 k=1,nl
+         do 2110 k=1,nd ! oct3
+          do 2120 i=1,ncum
+            ftra1(idcum(i),k,j)=ftra(i,k,j)
+ 2120     continue
+ 2110    continue
+ 2100   continue
+
+        return
+        end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_driver.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_driver.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_driver.F	(revision 428)
@@ -0,0 +1,670 @@
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,
+     &                   t1,q1,qs1,u1,v1,tra1,
+     &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,
+     &                   cbmf1,sig1,w01,
+     &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1)
+C
+      implicit none
+C
+C.............................START PROLOGUE............................
+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      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+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      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      iflag1        Integer        Output       flag for Emanuel conditions
+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      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      delt          Real           Input        time step
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux 
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3) 
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+#include "dimensions.h"
+#include "dimphy.h"
+
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real precip1(len)
+      real cbmf1(len)
+      real Ma1(len,nd)
+      real upwd1(len,nd)
+      real dnwd1(len,nd)
+      real dnwd01(len,nd)
+
+      real qcondc1(len,nd)     ! cld
+      real wd1(len)            ! gust
+      real cape1(len)     
+
+      real tra1(len,nd,ntra)
+      real ftra1(len,nd,ntra)
+
+      real delt
+
+!-------------------------------------------------------------------
+! --- 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 i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real th1(klon,klev)
+c
+      integer ncum
+c
+c (local) compressed fields:
+c
+      integer nloc
+      parameter (nloc=klon) ! pour l'instant
+
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters 
+c
+c 	includes microphysical parameters and parameters that 
+c  	control the rate of approach to quasi-equilibrium) 
+c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+      do 20 k=1,nd
+        do 10 i=1,len
+         ft1(i,k)=0.0
+         fq1(i,k)=0.0
+         fu1(i,k)=0.0
+         fv1(i,k)=0.0
+         tvp1(i,k)=0.0
+         tp1(i,k)=0.0
+         clw1(i,k)=0.0
+         gz1(i,k) = 0.
+
+         Ma1(i,k)=0.0
+         upwd1(i,k)=0.0
+         dnwd1(i,k)=0.0
+         dnwd01(i,k)=0.0
+         qcondc1(i,k)=0.0
+ 10     continue
+ 20   continue
+
+      do 30 j=1,ntra
+       do 31 k=1,nd
+        do 32 i=1,len
+         ftra1(i,k,j)=0.0
+ 32     continue    
+ 31    continue    
+ 30   continue    
+
+      do 60 i=1,len
+        precip1(i)=0.0
+        iflag1(i)=0
+        wd1(i)=0.0
+        cape1(i)=0.0
+ 60   continue
+
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1            ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1           ! nd->na
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1  ! nd->na
+     o                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+c       print*,'klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+       CALL cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                     ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,m,sig
+     o ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb    ! na->nd
+     :               ,t,q,qs,gz,u,v,tra,p,ph
+     :               ,th,tv,lv,cpn,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b
+     :                     ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                     ,tv,tvp
+     o                     ,iflag,precip,ft,fq,fu,fv,ftra
+     o                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+      if (iflag_con.eq.3) then
+       CALL cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag
+     :          ,precip,sig,w0
+     :          ,ft,fq,fu,fv,ftra
+     :          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     o          ,iflag1
+     o          ,precip1,sig1,w01
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc            
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+c differente de 10.0 dans convect3: 
+      cvflag_grav = .FALSE.
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+c-------------------------------------------------------------
+c Set thermodynamical constants for convectL
+c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      endif
+
+c constants consistent with LMDZ:
+      if (iflag_con.eq.3) then
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+       grav= 10.    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_routines.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_routines.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cv_routines.F	(revision 428)
@@ -0,0 +1,1752 @@
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL
+c (includes microphysical parameters and parameters that 
+c  control the rate of approach to quasi-equilibrium) 
+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)                 ***
+
+#include "cvparam.h"
+      integer nd
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+c
+      cu=0.70
+c
+      betad=10.0
+c
+      damp=0.1
+      alpha=0.2
+c
+      delta=0.01  ! cld
+c
+      return
+      end
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          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
+
+      return
+      end
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C================================================================
+
+#include "cvparam.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- 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
+
+      return
+      end
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax
+     :                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- 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)-t0)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*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-t0
+          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/(rrv*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-t0
+          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
+      return
+      end
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+c outputs:
+       integer iflag(len) ! also an input
+
+c local variables:
+       integer i
+
+
+      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
+ 
+      return
+      end
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd
+     :   ,iflag1,nk1,icb1
+     :   ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :   ,t1,q1,qs1,u1,v1,gz1
+     :   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o   ,iflag,nk,icb
+     o   ,cbmf,plcl,tnk,qnk,gznk
+     o   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+c local variables:
+      integer i,k,nn
+
+
+      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
+ 110  continue
+
+      if (nn.ne.ncum) then
+         print*,'strange! nn not equal to ncum: ',nn,ncum
+         stop
+      endif
+
+      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
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,dph,h,tv,lv
+     o                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- 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)-t0))+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)-t0)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*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-t0
+	       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/(rrv*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-t0
+	       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)-t0)
+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)-t0
+            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  --- 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
+c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      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
+        return
+        end
+c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb
+     :                     ,tv,tvp,p,ph,dph,plcl,cpn
+     :                     ,iflag,cbmf)
+      implicit none
+
+c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c-------------------------------------------------------------------
+c Compute icbmax. 
+c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX 
+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)
+     &  -rrd*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 --- 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
+
+       return
+       end
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1
+     :                    ,ph,t,q,qs,u,v,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,cbmf
+     :                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    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)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  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)
+     &         /(rrv*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
+       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
+       return
+       end
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                  ,h,lv,ep,sigp,clw,m,ment,elij
+     :                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c Initializations:
+c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         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,nl+1
+         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   ***  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
+        return
+        end
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :             ,ep,clw,frac,m,mp,qp,up,vp
+     :             ,wt,water,evap
+     :             ,ment,qent,uent,vent,nent,elij
+     :             ,tv,tvp
+     o             ,iflag,wd,qprime,tprime
+     o             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  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
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))
+     :           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+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))
+c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             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
+C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           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
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          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
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))         ! cld   
+     :       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                ! cld
+     :    siga(ij,i)=mac(ij,i)/wa(ij,i)                     ! cld   
+     :        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))     ! cld   
+     :          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum
+     :         ,iflag
+     :         ,precip,cbmf
+     :         ,ft,fq,fu,fv
+     :         ,Ma,qcondc            
+     :         ,iflag1
+     :         ,precip1,cbmf1
+     :         ,ft1,fq1,fu1,fv1
+     :         ,Ma1,qcondc1            
+     :                               )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+c local variables:
+      integer i,k
+
+        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)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvflag.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvflag.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvflag.h	(revision 428)
@@ -0,0 +1,3 @@
+      logical cvflag_grav
+
+      COMMON /cvflag/ cvflag_grav 
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam.h	(revision 428)
@@ -0,0 +1,25 @@
+c------------------------------------------------------------
+c Parameters for convectL:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real elcrit, tlcrit
+      real entp
+      real sigs, sigd
+      real omtrain, omtsnow, coeffr, coeffs
+      real dtmax
+      real cu
+      real betad
+      real alpha, damp
+      real delta
+
+      COMMON /cvparam/ noff, minorig, nl, nlp, nlm
+     :                ,elcrit, tlcrit
+     :                ,entp, sigs, sigd
+     :                ,omtrain, omtsnow, coeffr, coeffs
+     :                ,dtmax, cu, betad, alpha, damp, delta
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam3.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam3.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvparam3.h	(revision 428)
@@ -0,0 +1,24 @@
+c------------------------------------------------------------
+c Parameters for convectL, iflag_con=3:
+c (includes - microphysical parameters, 
+c			- parameters that control the rate of approach 
+c               to quasi-equilibrium)
+c			- noff & minorig (previously in input of convect1)
+c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigd, spfac
+      real pbcrit, ptcrit, epmax
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha
+      real delta
+      real betad
+
+      COMMON /cvparam3/  noff, minorig, nl, nlp, nlm
+     :                ,  sigd, spfac
+     :                ,pbcrit, ptcrit, epmax
+     :                ,omtrain
+     :                ,dtovsh, dpbase, dttrig
+     :                ,dtcrit, tau, beta, alpha, delta, betad
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvthermo.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvthermo.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/cvthermo.h	(revision 428)
@@ -0,0 +1,12 @@
+c Thermodynamical constants for convectL:
+
+      real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+      real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl
+      real eps, epsi, epsim1
+      real ginv, hrd
+      real grav
+
+      COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+     :                 ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl 
+     :                 ,eps, epsi, epsim1, ginv, hrd, grav
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/diagphy.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/diagphy.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/diagphy.F	(revision 428)
@@ -0,0 +1,405 @@
+      SUBROUTINE diagphy(airephy,tit,iprt
+     $    , tops, topl, sols, soll, sens
+     $    , evap, rain_fall, snow_fall, ts
+     $    , d_etp_tot, d_qt_tot, d_ec_tot
+     $    , fs_bound, fq_bound)
+C======================================================================
+C
+C Purpose:
+C    Compute the thermal flux and the watter mass flux at the atmosphere
+c    boundaries. Print them and also the atmospheric enthalpy change and
+C    the  atmospheric mass change.
+C
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+C                   (i.e. -1 * flux absorbed by the surface)
+C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+C                   (i.e. flux emited - flux absorbed by the surface)
+C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+C                   (kg/m2/s), positive up
+C rain_fall(klon)
+C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+C snow_fall(klon)
+C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+C ts(klon)----input-R- Surface temperature (K)
+C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+C                    change (W/m2)
+C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+C                    change (kg/m2/s)
+C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+C                    change (W/m2)
+C
+C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+C
+C J.L. Dufresne, July 2002
+C======================================================================
+C 
+      implicit none
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+c     Output variables
+      REAL fs_bound, fq_bound
+C
+C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+C
+      integer i
+C
+      integer pas
+      save pas
+      data pas/0/
+C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+C
+C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+C     la glace, on travaille par difference a la chaleur specifique de l'
+c     air sec. En effet, comme on travaille a niveau de pression donne,
+C     toute variation de la masse d'un constituant est totalement
+c     compense par une variation de masse d'air.
+C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront
+     $         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice
+     $           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront
+     $    + slat
+C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+C
+      IF (iprt.ge.1) write(6,6666) 
+     $    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+C
+      IF (iprt.ge.1) write(6,6668) 
+     $    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+C
+      IF (iprt.ge.2) write(6,6667) 
+     $    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot
+     $    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end
+
+C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime
+     e  ,t,q,ql,qs,u,v,paprs,pplay
+     s  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la physique. Suppose que les niveau de
+c    pression entre couche ne varie pas entre 2 appels.
+C
+C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+c bilans sont sauvegardes dans des tableaux indices. On parlera
+C "d'indice de diagnostic"
+c 
+C
+c======================================================================
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c qs-------input-R- solid watter (kg/kg)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c paprs----input-R- pression a intercouche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C     other (COMMON...)
+C     RCPD, RCPV, ....
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+
+c======================================================================
+C
+      DO k = 1, klev
+        DO i = 1, klon
+C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+C
+C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i) 
+     $        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*ql(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*qs(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimphy.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimphy.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimphy.h	(revision 428)
@@ -0,0 +1,10 @@
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2-1/jjm,
+     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
+c-----------------------------------------------------------------------
+      INTEGER nbtr ! nombre de vrais traceurs
+      PARAMETER (nbtr=nqmx-2+1/(nqmx-1))
+c-----------------------------------------------------------------------
+      REAL zmasq(KLON)
+      COMMON/terreoce/zmasq
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimsoil.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimsoil.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/dimsoil.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecribin.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecribin.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecribin.F	(revision 428)
@@ -0,0 +1,99 @@
+      SUBROUTINE ecribins(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim +1,jjm+1)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim +1
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+            zz(iim+1,j)=zz(1,j)
+         ENDDO
+c-----------------------------------------------------------------------
+#ifdef VPP
+      CALL ecriture(unit,zz,(iim+1)*(jjm+1))
+#else
+      WRITE(unit) zz
+#endif
+c
+
+      RETURN
+      END
+      SUBROUTINE ecribina(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim+1,jjm+1,llm)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim +1
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+            zz(iim+1,j,ilay)=zz(1,j,ilay)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+#ifdef VPP
+         CALL ecriture(unit, zz(1,1,ilay), (iim+1)*(jjm+1))
+#else
+         WRITE(unit) ((zz(i,j,ilay),i=1,iim +1),j=1,jjm+1)
+#endif
+      ENDDO
+c
+      RETURN
+      END
+#ifdef VPP
+@OPTIONS NODOUBLE
+      SUBROUTINE ecriture(nunit, r8, n)
+      INTEGER nunit, n, i
+      REAL*8 r8(n)
+      REAL*4 r4(n)
+      DO i = 1, n
+         r4(i) = r8(i)
+      ENDDO
+      WRITE(nunit)r4
+      RETURN
+      END
+#endif
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecrireg.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecrireg.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ecrireg.F	(revision 428)
@@ -0,0 +1,116 @@
+      SUBROUTINE ecriregs(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon)
+c
+c   local:
+c   ------
+      INTEGER i,j, ig
+      REAL zz(iim,jjm+1)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+         DO i=1,iim
+            zz(i,1)=pz(1)
+            zz(i,jjm+1)=pz(klon)
+         ENDDO
+c
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig),1,zz(1,j),1)
+         ENDDO
+c-----------------------------------------------------------------------
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      RETURN
+      END
+      SUBROUTINE ecrirega(unit,pz)
+      IMPLICIT none
+c-----------------------------------------------------------------------
+#include "dimensions.h"
+#include "dimphy.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "regdim.h"
+c
+c   arguments:
+c   ----------
+      INTEGER unit
+      REAL pz(klon,klev)
+c
+c   local:
+c   ------
+      INTEGER i,j,ilay,ig
+      REAL zz(iim,jjm+1,llm)
+      INTEGER nleng
+      PARAMETER (nleng=(i2_fin-i2_deb+1+i1_fin-i1_deb+1)
+     .                *(j_fin-j_deb+1))
+      REAL zzz(nleng)
+c-----------------------------------------------------------------------
+c   passage a la grille dynamique:
+c   ------------------------------
+      DO ilay=1,llm
+c   traitement des poles
+         DO i=1,iim
+            zz(i,1,ilay)=pz(1,ilay)
+            zz(i,jjm+1,ilay)=pz(klon,ilay)
+         ENDDO
+c   traitement des point normaux
+         DO j=2,jjm
+            ig=2+(j-2)*iim
+            CALL SCOPY(iim,pz(ig,ilay),1,zz(1,j,ilay),1)
+         ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+      DO ilay = 1, llm
+      ig = 0
+      DO j = j_deb, j_fin
+         DO i=i1_deb,i1_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+         DO i=i2_deb,i2_fin
+            ig = ig + 1
+            zzz(ig) = zz(i,j,ilay)
+         ENDDO
+      ENDDO
+#ifdef VPP
+      CALL ecriture(unit,zzz,nleng)
+#else
+      WRITE(unit) zzz
+#endif
+      ENDDO
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.F	(revision 428)
@@ -0,0 +1,535 @@
+c $Header$
+c
+      SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,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                   prfl, psfl, rhcl)
+
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+#include "fisrtilp.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      REAL rhcl(klon,klev) ! humidite relative en ciel clair
+      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
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+      real zct(klon),zcl(klon)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+
+      INTEGER ninter ! sous-intervals pour la precipitation
+      PARAMETER (ninter=5)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+      logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur
+
+      real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+      real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
+      real erf
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+      REAL zmair, zcpair, zcpeau
+C     Pour la conversion eau-neige
+      REAL zlh_solid(klon), zm_solid
+cIM 
+      INTEGER klevm1
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+      fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+c
+      DATA appel1er /.TRUE./
+
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+c         CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c  nexpo regle la raideur de la transition eau liquide / eau glace.
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+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
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+cIM : klevm1
+      klevm1=klev-1
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer la varition de temp. de l'air du a la chaleur sensible
+C transporter par la pluie.
+C Il resterait a rajouter cet effet de la chaleur sensible sur les
+C flux de surface, du a la diff. de temp. entre le 1er niveau et la
+C surface.
+C
+      DO i = 1, klon
+cIM
+       IF(k.LE.klevm1) THEN         
+        zmair=(paprs(i,k)-paprs(i,k+1))/RG
+        zcpair=RCPD*(1.0+RVTMP2*zq(i))
+        zcpeau=RCPD*RVTMP2
+        zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau
+     $      + zmair*zcpair*zt(i) )
+     $      / (zmair*zcpair + zrfl(i)*dtime*zcpeau)
+CC        WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1))
+       ENDIF
+      ENDDO
+c
+c
+c Calculer l'evaporation de la precipitation
+c
+
+
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+
+c pour la glace, on réévapore toute la précip dans la couche du dessous
+c la glace venant de la couche du dessus est simplement dans la couche
+c du dessous.
+
+         IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+
+c        print*,'Dans partiel k=',k
+c
+c   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+c   nuageuse a partir des PDF de Sandrine Bony.
+c   rneb  : fraction nuageuse
+c   zqn   : eau totale dans le nuage
+c   zcond : eau condensee moyenne dans la maille.
+c           on prend en compte le réchauffement qui diminue la partie condensee
+c
+c   Version avec les raqts
+
+         if (iflag_pdf.eq.0) then
+
+           do i=1,klon
+            zdelq = min(ratqs(i,k),0.99) * zq(i)
+            rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+            zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+         else
+c
+c   Version avec les nouvelles PDFs.
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                print*,'ZQ(',i,',',k,')=',zq(i)
+                zq(i)=1.e-15
+              endif
+           enddo
+           do i=1,klon
+            zpdf_sig(i)=ratqs(i,k)*zq(i)
+            zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+            zpdf_delta(i)=log(zq(i)/zqs(i))
+            zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+            zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+            zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+            zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+            zpdf_e1(i)=1.-erf(zpdf_e1(i))
+            zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+            zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+            zpdf_e2(i)=1.-erf(zpdf_e2(i))
+            if (zpdf_e1(i).lt.1.e-10) then
+               rneb(i,k)=0.
+               zqn(i)=zqs(i)
+            else
+               rneb(i,k)=0.5*zpdf_e1(i)
+               zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+            endif
+            
+           enddo
+
+        endif ! iflag_pdf
+
+         do i=1,klon
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+c           zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+c  On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par
+c  la convection.
+c  ATTENTION !!! Il va falloir verifier tout ca.
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+c           print*,'ZDQS ',zdqs(i)
+c--Olivier
+            rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+            IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i)
+            IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0
+c--fin
+           ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+c         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+
+         if (ptconv(i,k)) then
+            zcl(i)=cld_lc_con
+            zct(i)=1./cld_tau_con
+         else
+            zcl(i)=cld_lc_lsc
+            zct(i)=1./cld_tau_lsc
+         endif
+c  quantité d'eau à élminier.
+         zchau(i) = zct(i)*dtime/FLOAT(ninter) * zoliq(i)
+     .         *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl(i))**2)) *(1.-zfice(i))
+c  meme chose pour la glace.
+         if (ptconv(i,k)) then
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvc(zrhol(i)) * zfice(i)
+         else
+            zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallvs(zrhol(i)) * zfice(i)
+         endif
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (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
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         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(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            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(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
+        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----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+         zlh_solid(i) = RLSTT-RLVTT
+      ELSE
+         rain(i) = zrfl(i)
+         zlh_solid(i) = 0.
+      ENDIF
+      ENDDO
+C
+C For energy conservation : when snow is present, the solification
+c latent heat is considered.
+      DO k = 1, klev
+        DO i = 1, klon
+          zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+          zmair=(paprs(i,k)-paprs(i,k+1))/RG
+          zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+          d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair)
+        END DO 
+      END DO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.h	(revision 428)
@@ -0,0 +1,18 @@
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/
+     s     cld_lc_lsc     ! 2.6e-4
+     s     ,cld_lc_con    ! 2.6e-4
+     s     ,cld_tau_lsc   ! 3600.
+     s     ,cld_tau_con   ! 3600.
+     s     ,ffallv_lsc    ! 1.
+     s     ,ffallv_con    ! 1.
+     s     ,coef_eva      ! 2.e-5
+     s     ,reevap_ice    ! F
+     s     ,iflag_pdf     ! 0
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp.inc	(revision 428)
@@ -0,0 +1,18 @@
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/ &
+     &     cld_lc_lsc     &
+     &     ,cld_lc_con   &
+     &     ,cld_tau_lsc &
+     &     ,cld_tau_con &
+     &     ,ffallv_lsc &
+     &     ,ffallv_con &
+     &     ,coef_eva  &
+     &     ,reevap_ice  &
+     &     ,iflag_pdf  
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp_tr.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp_tr.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/fisrtilp_tr.F	(revision 428)
@@ -0,0 +1,418 @@
+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                   prfl, psfl)
+
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Date: le 20 mars 1995
+c Objet: condensation et precipitation stratiforme.
+c        schema de nuage
+c======================================================================
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "tracstoke.h"
+c
+c Arguments:
+c
+      REAL dtime ! intervalle du temps (s)
+      REAL paprs(klon,klev+1) ! pression a inter-couche
+      REAL pplay(klon,klev) ! pression au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (kg/kg)
+      REAL d_t(klon,klev) ! incrementation de la temperature (K)
+      REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+      REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+      REAL rneb(klon,klev) ! fraction nuageuse
+      REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+      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
+c
+      REAL pfrac_nucl(klon,klev)
+      REAL pfrac_1nucl(klon,klev)
+      REAL pfrac_impa(klon,klev)
+c
+c Fraction d'aerosols lessivee par impaction et par nucleation
+c POur ON-LINE
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+cAA
+c
+c Options du programme:
+c
+      REAL seuil_neb ! un nuage existe vraiment au-dela
+      PARAMETER (seuil_neb=0.001)
+      REAL ct ! inverse du temps pour qu'un nuage precipite
+      PARAMETER (ct=1./1800.)
+      REAL cl ! seuil de precipitation
+      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)
+      LOGICAL evap_prec ! evaporation de la pluie
+      PARAMETER (evap_prec=.TRUE.)
+      REAL coef_eva
+      PARAMETER (coef_eva=2.0E-05)
+      LOGICAL calcrat ! calculer ratqs au lieu de fixer sa valeur
+      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)
+      REAL zx_max, rat_min
+      PARAMETER (zx_max=0.1, rat_min=0.3)
+      REAL zx
+c
+      LOGICAL cpartiel ! condensation partielle
+      PARAMETER (cpartiel=.TRUE.)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+c
+      INTEGER i, k, n, kk
+      REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5
+      REAL zrfl(klon), zrfln(klon), zqev, zqevt
+      REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+      REAL ztglace, zt(klon)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      REAL zdz(klon),zrho(klon),ztot(klon), zrhol(klon)
+      REAL zchau(klon),zfroi(klon),zfice(klon),zneb(klon)
+c
+      LOGICAL appel1er
+      SAVE appel1er
+c
+c---------------------------------------------------------------
+c
+cAA Variables traceurs:
+cAA  Provisoire !!! Parametres alpha du lessivage
+cAA  A priori on a 4 scavenging # possibles
+c
+      REAL a_tr_sca(4)
+      save a_tr_sca
+c
+c Variables intermediaires
+c
+      REAL zalpha_tr
+      REAL zfrac_lessi
+      REAL zprec_cond(klon)
+cAA
+c---------------------------------------------------------------
+c
+c Fonctions en ligne:
+c
+      REAL fallv ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      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./
+c
+      IF (appel1er) THEN
+c
+         PRINT*, 'fisrtilp, calcrat:', calcrat
+         PRINT*, 'fisrtilp, ninter:', ninter
+         PRINT*, 'fisrtilp, evap_prec:', evap_prec
+         PRINT*, 'fisrtilp, cpartiel:', cpartiel
+         IF (ABS(dtime/FLOAT(ninter)-360.0).GT.0.001) THEN
+          PRINT*, 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+          PRINT*, 'Je prefere un sous-intervalle de 6 minutes'
+          CALL abort
+         ENDIF
+         appel1er = .FALSE.
+c
+cAA initialiation provisoire
+       a_tr_sca(1) = -0.5
+       a_tr_sca(2) = -0.5
+       a_tr_sca(3) = -0.5
+       a_tr_sca(4) = -0.5
+c
+cAA Initialisation a 1 des coefs des fractions lessivees 
+c
+      DO k = 1, klev
+       DO i = 1, klon
+          pfrac_nucl(i,k)=1.
+          pfrac_1nucl(i,k)=1.
+          pfrac_impa(i,k)=1.
+       ENDDO 
+      ENDDO 
+
+      ENDIF          !  test sur appel1er
+c
+cMAf Initialisation a 0 de zoliq
+       DO i = 1, klon
+          zoliq(i)=0.
+       ENDDO 
+c Determiner les nuages froids par leur temperature
+c
+      ztglace = RTT - 15.0
+      nexpo = 6
+ccc      nexpo = 1
+c
+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
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         d_ql(i,k) = 0.0
+         rneb(i,k) = 0.0
+         radliq(i,k) = 0.0
+         frac_nucl(i,k) = 1. 
+         frac_impa(i,k) = 1. 
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+      ENDDO
+c
+c Initialiser le flux de precipitation a zero
+c
+      DO i = 1, klon
+         zrfl(i) = 0.0
+         zneb(i) = seuil_neb
+      ENDDO
+c
+c
+cAA Pour plus de securite 
+
+      zalpha_tr   = 0.
+      zfrac_lessi = 0.
+
+cAA----------------------------------------------------------
+c
+c Boucle verticale (du haut vers le bas)
+c
+      DO 9999 k = klev, 1, -1
+c
+cAA----------------------------------------------------------
+c
+      DO i = 1, klon
+         zt(i)=t(i,k)
+         zq(i)=q(i,k)
+      ENDDO
+c
+c Calculer l'evaporation de la precipitation
+c
+      IF (evap_prec) THEN
+      DO i = 1, klon
+      IF (zrfl(i) .GT.0.) THEN
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+           zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i)=MIN(0.5,zqs(i))
+           zcor=1./(1.-RETV*zqs(i))
+           zqs(i)=zqs(i)*zcor
+         ELSE
+           IF (zt(i) .LT. t_coup) THEN
+              zqs(i) = qsats(zt(i)) / pplay(i,k)
+           ELSE
+              zqs(i) = qsatl(zt(i)) / pplay(i,k)
+           ENDIF
+         ENDIF
+         zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+         zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i))
+     .         * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+         zqevt = MAX(0.0,MIN(zqevt,zrfl(i)))
+     .         * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+         zqev = MIN (zqev, zqevt)
+         zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1))
+     .                            /RG/dtime
+         zq(i) = zq(i) - (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+         zt(i) = zt(i) + (zrfln(i)-zrfl(i))
+     .             * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+     .             * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+         zrfl(i) = zrfln(i)
+      ENDIF
+      ENDDO
+      ENDIF
+c
+c Calculer Qs et L/Cp*dQs/dT:
+c
+      IF (thermcep) THEN
+         DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zt(i).LT.t_coup) THEN
+               zqs(i) = qsats(zt(i))/pplay(i,k)
+               zdqs(i) = dqsats(zt(i),zqs(i))
+            ELSE
+               zqs(i) = qsatl(zt(i))/pplay(i,k)
+               zdqs(i) = dqsatl(zt(i),zqs(i))
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c Determiner la condensation partielle et calculer la quantite
+c de l'eau condensee:
+c
+      IF (cpartiel) THEN
+         DO i = 1, klon
+c
+            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
+            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            IF (zq(i).GT.zqs(i)) THEN
+               rneb(i,k) = 1.0
+            ELSE
+               rneb(i,k) = 0.0
+            ENDIF
+            zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+         ENDDO
+      ENDIF
+c
+      DO i = 1, klon
+         zq(i) = zq(i) - zcond(i)
+         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+      ENDDO
+c
+c Partager l'eau condensee en precipitation et eau liquide nuageuse
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zoliq(i) = zcond(i)
+         zrho(i) = pplay(i,k) / zt(i) / RD
+         zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+         zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+         zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+         zfice(i) = zfice(i)**nexpo
+         zneb(i) = MAX(rneb(i,k), seuil_neb)
+         radliq(i,k) = zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+c
+      DO n = 1, ninter
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         zchau(i) = ct*dtime/FLOAT(ninter) * zoliq(i)
+     .          * (1.0-EXP(-(zoliq(i)/zneb(i)/cl)**2)) *(1.-zfice(i))
+         zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+         zfroi(i) = dtime/FLOAT(ninter)/zdz(i)*zoliq(i)
+     .              *fallv(zrhol(i)) * zfice(i)
+         ztot(i) = zchau(i) + zfroi(i)
+         IF (zneb(i).EQ.seuil_neb) ztot(i) = 0.0
+         ztot(i) = MIN(MAX(ztot(i),0.0),zoliq(i))
+         zoliq(i) = MAX(zoliq(i)-ztot(i), 0.0)
+         radliq(i,k) = radliq(i,k) + zoliq(i)/FLOAT(ninter+1)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (rneb(i,k).GT.0.0) THEN
+         d_ql(i,k) = zoliq(i)
+         zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0)
+     .                    * (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
+c Calculer les tendances de q et de t:
+c
+      DO i = 1, klon
+         d_q(i,k) = zq(i) - q(i,k)
+         d_t(i,k) = zt(i) - t(i,k)
+      ENDDO
+c
+cAA--------------- Calcul du lessivage stratiforme  -------------
+
+      DO i = 1,klon
+c
+         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(i).gt.0.) THEN
+cAA lessivage nucleation LMD5 dans la couche elle-meme
+            if (t(i,k) .GE. ztglace) THEN
+               zalpha_tr = a_tr_sca(3)
+            else
+               zalpha_tr = a_tr_sca(4)
+            endif
+            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(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
+        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----------------------------------------------------------
+c                     FIN DE BOUCLE SUR K   
+ 9999 CONTINUE
+c
+cAA-----------------------------------------------------------
+c
+c Pluie ou neige au sol selon la temperature de la 1ere couche
+c
+      DO i = 1, klon
+      IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+         snow(i) = zrfl(i)
+      ELSE
+         rain(i) = zrfl(i)
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/flxtr.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/flxtr.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/flxtr.F	(revision 428)
@@ -0,0 +1,203 @@
+      SUBROUTINE flxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pt,pplay,paprs,kcbot,kctop,kdtop,x,dx) 
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux, kcbot, kctop et kdtop
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --Un schema amont est choisi pour calculer les flux pour s'assurer 
+c   de la positivite des valeurs de traceurs, cela implique des eqs 
+c   differentes pour les flux de traceurs montants et descendants.
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      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--idem mais en variables locales
+      REAL zpen_u(klon,klev) 
+      REAL zpde_u(klon,klev)
+      REAL zpen_d(klon,klev) 
+      REAL zpde_d(klon,klev)
+c
+      REAL pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL pap(klon,klev)      ! pression aux couches (haut en bas)
+      REAL pt(klon,klev)       ! temperature aux couches (bas en haut) 
+      REAL zt(klon,klev)       ! temperature aux couches (haut en bas)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL paph(klon,klev+1)   ! pression aux 1/2 couches (haut en bas)
+      INTEGER kcbot(klon)      ! niveau de base de la convection
+      INTEGER kctop(klon)      ! niveau du sommet de la convection +1 
+      INTEGER kdtop(klon)      ! niveau de sommet du panache descendant
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL zx(klon,klev)       ! q de traceur (haut en bas)
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL xe(klon,klev)        ! q de traceurs dans l'environnement 
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+c
+c On remet les taux d'entrainement et de detrainement dans le panache
+c descendant a des valeurs positives. 
+c On ajuste les valeurs de pen_u, pen_d pde_u et pde_d pour que la 
+c conservation de la masse soit realisee a chaque niveau dans les 2 
+c panaches.
+      DO k=1, klev
+      DO i=1, klon
+        zpen_u(i,k)= pen_u(i,k)
+        zpde_u(i,k)= pde_u(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO k=1, klev-1
+      DO i=1, klon
+        zpen_d(i,k)=-pen_d(i,k+1)
+        zpde_d(i,k)=-pde_d(i,k+1)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon 
+      zpen_d(i,klev)       = 0.0
+      zpde_d(i,klev)       = -pmfd(i,klev)
+c   Correction 03 11 97
+c     zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      IF (kdtop(i).EQ.klev+1) THEN
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)
+      ELSE
+      zpen_d(i,kdtop(i)-1) = pmfd(i,kdtop(i)-1)-pmfd(i,kdtop(i))
+      ENDIF
+
+      zpde_u(i,kctop(i)-2) = pmfu(i,kctop(i)-1)
+      zpen_u(i,klev)       = pmfu(i,klev) 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=kcbot(i), klev-1
+      zpen_u(i,k) = pmfu(i,k) - pmfu(i,k+1)
+      ENDDO 
+      ENDDO 
+c
+c conversion des sens de notations bas-haut et haut-bas
+c
+      DO k=1, klev+1 
+      DO i=1, klon 
+        paph(i,klev+2-k)=paprs(i,k)
+      ENDDO 
+      ENDDO
+c
+      DO i=1, klon
+      DO k=1, klev 
+        pap(i,klev+1-k)=pplay(i,k)
+        zt(i,klev+1-k) =pt(i,k)
+        zx(i,klev+1-k) =x(i,k) 
+      ENDDO 
+      ENDDO
+c
+c--initialisations des flux de traceurs aux extremites de la colonne
+c
+      DO i=1, klon 
+        zmfux(i,klev+1) = 0.0 
+        zmfdx(i,1) = 0.0 
+        zmfex(i,1) = 0.0 
+      ENDDO
+c
+c--calcul des flux dans le panache montant
+c
+      DO k=klev, 1, -1
+      DO i=1, klon
+       IF (k.GE.kcbot(i)) THEN 
+         xu(i,k)=zx(i,k)
+         zmfux(i,k)=pmfu(i,k)*xu(i,k)
+       ELSE 
+         zmfux(i,k)= (zmfux(i,k+1) + zpen_u(i,k)*zx(i,k) ) / 
+     .               (1.+zpde_u(i,k)/MAX(zmfmin,pmfu(i,k)))
+         xu(i,k)=zmfux(i,k)/MAX(zmfmin,pmfu(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c--calcul des flux dans le panache descendant
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kdtop(i)-1) THEN
+         xd(i,k)=( zx(i,k)+xu(i,k) ) / 2. 
+         zmfdx(i,k+1)=pmfd(i,k+1)*xd(i,k)
+       ELSE
+         zmfdx(i,k+1)= (zmfdx(i,k) - zpen_d(i,k)*zx(i,k) ) /
+     .               (1.-zpde_d(i,k)/MIN(-zmfmin,pmfd(i,k+1)))
+         xd(i,k)=zmfdx(i,k+1)/MIN(-zmfmin,pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfdx(i,klev+1) = 0.0 
+         xd(i,klev) = (zpen_d(i,klev)*zx(i,klev) - zmfdx(i,klev)) / 
+     .                   MAX(zmfmin,zpde_d(i,klev)) 
+      ENDDO 
+c
+c--introduction du flux de retour dans l'environnement
+c
+      DO k=1, klev-1
+      DO i=1, klon
+       IF (k.LE.kctop(i)-3) THEN 
+         xe(i,k)= zx(i,k) 
+         zmfex(i,k+1)=-(pmfu(i,k+1)+pmfd(i,k+1))*xe(i,k)
+       ELSE 
+         zmfex(i,k+1)= (zmfex(i,k) - 
+     .      (zpde_u(i,k)*xu(i,k)+zpde_d(i,k)*xd(i,k))) /
+     .      (1.-(zpen_d(i,k)+zpen_u(i,k))/
+     .      MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1)) )
+         xe(i,k)=zmfex(i,k+1)/MIN(-zmfmin,-pmfu(i,k+1)-pmfd(i,k+1))
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i=1, klon 
+         zmfex(i,klev+1) = 0.0
+         xe(i,klev) = (zpde_u(i,klev)*xu(i,klev) + 
+     .                 zpde_d(i,klev)*xd(i,klev) -zmfex(i,klev)) /
+     .                 MAX(zmfmin,zpen_u(i,klev)+zpen_d(i,klev)) 
+      ENDDO
+c
+c--calcul final des tendances
+c
+      DO k=1 , klev
+      DO i=1, klon
+        dx(i,klev+1-k) = RG/(paph(i,k+1)-paph(i,k))*pdtime*
+     .                      ( zmfux(i,k+1) - zmfux(i,k) +
+     .                        zmfdx(i,k+1) - zmfdx(i,k) +
+     .                        zmfex(i,k+1) - zmfex(i,k) )
+      ENDDO
+      ENDDO
+c
+      RETURN 
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hgardfou.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hgardfou.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hgardfou.F	(revision 428)
@@ -0,0 +1,115 @@
+      SUBROUTINE hgardfou (t,tsol,text)
+      IMPLICIT none
+c======================================================================
+c Verifier la temperature
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+      IF (firstcall) THEN
+         PRINT*, 'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+      ENDIF
+c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,k,temperature =',jadrs(i),k,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+         DO i = 1, klon
+            zt(i) = tsol(i,nsrf)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             PRINT *,'i,nsrf,temperature =',jadrs(i),nsrf,zt(jadrs(i))
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      IF (.NOT. ok) THEN
+         PRINT*, 'hgardfou s arrete ', text
+         CALL abort
+      ENDIF
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/homogene.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/homogene.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/homogene.F	(revision 428)
@@ -0,0 +1,96 @@
+      SUBROUTINE homogene(paprs, q, dq, u,v, du, dv)
+      IMPLICIT NONE
+c==============================================================
+c Schema ad hoc du melange vertical pour les vitesses u et v,
+c a appliquer apres le schema de convection (fiajc et fiajh).
+c
+c paprs:input, pression demi-couche (inter-couche)
+c q:    input, vapeur d'eau (kg/kg)
+c dq:   input, incrementation de vapeur d'eau (de la convection)
+c u:    input, vitesse u
+c v:    input, vitesse v
+c
+c du:   output, incrementation pour u
+c dv:   output, incrementation pour v
+c==============================================================
+#include "dimensions.h"
+#include "dimphy.h"
+c
+      REAL paprs(klon,klev+1)
+      REAL q(klon,klev), dq(klon,klev)
+      REAL u(klon,klev), du(klon,klev)
+      REAL v(klon,klev), dv(klon,klev)
+c
+      REAL zm_dq(klon) ! quantite totale de l'eau deplacee
+      REAL zm_q(klon)  ! quantite totale de la vapeur d'eau
+      REAL zm_u(klon)  ! moyenne de u (brassage parfait et total)
+      REAL zm_v(klon)  ! moyenne de v (brassage parfait et total)
+      REAL z_frac(klon) ! fraction du brassage parfait et total
+      REAL zm_dp(klon)
+c
+      REAL zx
+      INTEGER i, k
+      REAL frac_max
+      PARAMETER (frac_max=0.1)
+      REAL seuil
+      PARAMETER (seuil=1.0e-10)
+      LOGICAL faisrien
+      PARAMETER (faisrien=.true.)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         du(i,k) = 0.0
+         dv(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      IF (faisrien) RETURN
+c
+      DO i = 1, klon
+         zm_dq(i)=0.
+         zm_q(i) =0.
+         zm_u(i)=0.
+         zm_v(i)=0.
+         zm_dp(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (ABS(dq(i,k)).GT.seuil) THEN
+         zx = paprs(i,k) - paprs(i,k+1)
+         zm_dq(i) = zm_dq(i) + ABS(dq(i,k))*zx
+         zm_q(i) = zm_q(i) + q(i,k)*zx
+         zm_dp(i) = zm_dp(i) + zx
+         zm_u(i) = zm_u(i) + u(i,k)*zx
+         zm_v(i) = zm_v(i) + v(i,k)*zx
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Hypothese principale: apres la convection, la vitesse de chaque
+c couche est composee de deux parties: celle (1-z_frac) de la vitesse 
+c original et celle (z_frac) de la vitesse moyenne qui serait la
+c vitesse de chaque couche si le brassage etait parfait et total.
+c La fraction du brassage est calculee par le rapport entre la quantite
+c totale de la vapeur d'eau deplacee (ou condensee) et la quantite
+c totale de la vapeur d'eau. Et cette fraction est limitee a frac_max 
+c (Est-ce vraiment raisonnable ? Z.X. Li, le 07-09-1995).
+c
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.0E-15 .AND. zm_q(i).GE.1.0E-15) THEN
+         z_frac(i)=MIN(frac_max,zm_dq(i)/zm_q(i))
+         zm_u(i)=zm_u(i)/zm_dp(i)
+         zm_v(i)=zm_v(i)/zm_dp(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (zm_dp(i).GE.1.e-15 .AND. zm_q(i).GE.1.e-15
+     .                         .AND. ABS(dq(i,k)).GT.seuil) THEN
+         du(i,k) = u(i,k)*(1.-z_frac(i)) + zm_u(i)*z_frac(i) - u(i,k)
+         dv(i,k) = v(i,k)*(1.-z_frac(i)) + zm_v(i)*z_frac(i) - v(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hydrol.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hydrol.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/hydrol.F	(revision 428)
@@ -0,0 +1,111 @@
+      SUBROUTINE hydrol(dtime,pctsrf,rain_fall,snow_fall,evap,
+     .                  agesno, tsol,qsol,snow,runoff)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940414
+c======================================================================
+c
+c Traitement de l'hydrologie du sol
+c ---------------------------------
+c rain_fall: taux de pluie
+c snow_fall: taux de neige
+c agesno: age de la neige
+c evap: taux d'evaporation
+c tsol: temperature du sol
+c qsol: humidite du sol
+c snow: couverture neigeuse
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "indicesol.h"
+c
+      REAL chasno ! epaisseur du sol: 0.15 m
+      PARAMETER (chasno=3.334E+05/(2.3867E+06*0.15))
+      REAL mx_eau_sol
+      PARAMETER (mx_eau_sol=150.0)
+c
+      REAL dtime
+      REAL pctsrf(klon,nbsrf)
+      REAL snow(klon,nbsrf), tsol(klon,nbsrf), qsol(klon,nbsrf)
+      REAL snow_fall(klon), rain_fall(klon), evap(klon)
+      REAL runoff(klon), agesno(klon)
+C
+      INTEGER i, is
+      REAL subli, fsno
+C-----------------------------------------------------------------------
+      DO 99999 i = 1, klon
+c
+         runoff(i) = 0.0
+c
+         is = is_ter
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_lic
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+            qsol(i,is) = qsol(i,is) + (rain_fall(i)-evap(i))*dtime
+     .                              + subli + fsno
+            qsol(i,is) = MAX(qsol(i,is),0.0)
+            runoff(i) = runoff(i) + MAX(qsol(i,is)-mx_eau_sol, 0.0)
+     .                            * pctsrf(i,is)
+            qsol(i,is) = MIN(qsol(i,is),mx_eau_sol)
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+      tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            qsol(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         is = is_sic
+         qsol(i,is) = 0.0
+         snow(i,is) = snow(i,is) + snow_fall(i) * dtime * pctsrf(i,is)
+         IF (pctsrf(i,is) .GT. epsfra) THEN
+            subli = MIN(evap(i)*dtime,snow(i,is))
+            snow(i,is) = snow(i,is) - subli
+            fsno = MIN(MAX((tsol(i,is)-RTT)/chasno,0.0),snow(i,is))
+            snow(i,is) = snow(i,is) - fsno
+            tsol(i,is) = tsol(i,is) - fsno*chasno
+c je limite la temperature a RTT-1.8 (il faudrait aussi prendre l'eau de
+c la fonte) (Laurent Li, le 14mars98):
+      tsol(i,is) = MIN(tsol(i,is),RTT-1.8)
+c
+ccc         ELSE
+ccc            snow(i,is) = 0.0
+ccc            tsol(i,is) = 0.0
+         ENDIF
+c
+         agesno(i) = (agesno(i)+ (1.-agesno(i)/50.)*dtime/86400.)
+     .             * EXP(-1.*MAX(0.0,snow_fall(i))*dtime/0.3)
+         agesno(i) = MAX(agesno(i),0.0)
+c
+99999 CONTINUE
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inc_cpl.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inc_cpl.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inc_cpl.h	(revision 428)
@@ -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*8 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/IPSL-CM4_v1x1/libf/phylmd/inc_sipc.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inc_sipc.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inc_sipc.h	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/indicesol.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/indicesol.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/indicesol.h	(revision 428)
@@ -0,0 +1,17 @@
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+!
+      INTEGER is_oce
+      PARAMETER (is_oce=3) ! ocean
+      INTEGER is_sic
+      PARAMETER (is_sic=4) ! glace de mer
+      INTEGER is_ter
+      PARAMETER (is_ter=1) ! terre
+      INTEGER is_lic
+      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/IPSL-CM4_v1x1/libf/phylmd/indicesol.inc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/indicesol.inc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/indicesol.inc	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/ini_histday.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histday.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histday.h	(revision 428)
@@ -0,0 +1,342 @@
+      IF (ok_journe) THEN
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+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,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         write(*,*)'zx_lon = ',zx_lon(:,1)
+         write(*,*)'zx_lat = ',zx_lat(1,:)
+         CALL histbeg("histday", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+     .                 nhori, nid_day)
+         write(*,*)'Journee ', itau_phy, zjulian
+         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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_day, "aire", "Grid area", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
+     .                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
+cccIM
+c
+         CALL histdef(nid_day, "t2m", "Temperature 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "t2mter", "Temp.terre 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "t2mlic", "Temp.lic 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "t2moce", "Temp.oce 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "t2msic", "Temp.sic 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "t2m_min", "Temp. 2m min.",
+     .                "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zsto,zout)
+c
+         CALL histdef(nid_day, "t2m_max", "Temp. 2m max.",
+     .                "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zsto,zout)
+c
+         CALL histdef(nid_day, "t2mter_min", "Temp.terre 2m min.",
+     .                "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                t2mincels, zsto,zout)
+c
+         CALL histdef(nid_day, "t2mter_max", "Temp.terre 2m max.",
+     .                "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                t2maxcels, zsto,zout)
+c
+         CALL histdef(nid_day, "q2m", "Specific humidity", "Kg/Kg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "u10mter", "Vent zonal ter 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "u10mlic", "Vent zonal lic 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "u10moce", "Vent zonal oce 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "u10msic", "Vent zonal sic 10m",
+     .                 "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "v10mter", "Vent meridien ter 10m", 
+     .                "m/s", iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "v10mlic", "Vent meridien lic 10m",
+     .                 "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "v10moce", "Vent meridien oce 10m",
+     .                 "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "v10msic", "Vent meridien sic 10m",
+     .                 "m/s",iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "precip","Precipitation Totale liq+sol"
+     .                , "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "snow", "Snow fall", "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "snow_mass", "Snow Mass", "kg/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "evap", "Evaporation", "kg/s",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "sols", "Net Solar rad. at surf.", 
+     .                "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "soll", "Net IR rad. at surface", "W/m2",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "frtu", "Zonal wind stress", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "frtv", "Meridional wind stress", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+CXXX PB flux pour chaque 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)
+
+CXXX
+         END DO 
+           
+         CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldq", "Cloud liquid water path", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_day, "temp", "Air temperature", "K",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "ovap", "Specific humidity", "Kg/Kg",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "geop", "Geopotential height", "m",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitw", "Vertical wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "pres", "Air pressure", "Pa",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+cccIM   
+         CALL histdef(nid_day, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histend(nid_day)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_journe
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histhf.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histhf.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histhf.h	(revision 428)
@@ -0,0 +1,91 @@
+
+      IF (ok_hf) THEN
+c
+         PRINT*, 'La frequence de sortie instant. est de ', ecrit_hf
+
+cccIM    CALL ymds2ju(anne_ini, 1, 1, 0.0, zjulian)
+         CALL ymds2ju(annee_ref, 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,jjmp1) = rlon(i+1)
+         ENDDO
+
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+
+cccIM      CALL histbeg("histhf", iim,zx_lon, jjmp1,zx_lat,
+         CALL histbeg("histhf", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,iim,1,jjmp1, 0, zjulian, dtime, 
+     .                 nhori, nid_hf)
+
+         CALL histvert(nid_hf, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+         zsto = dtime
+
+c   pour les champs instantannes, il faut mettre la meme valeur pour
+c   zout et tsto.
+c   dtime est passe par ailleurs a histbeg
+
+         zout = dtime * REAL(NINT(86400./dtime*ecrit_hf))
+         zsto = zout
+         print*,'zout,zsto=',zout,zsto
+
+c
+c        CALL histdef(nid_hf, "phis", "Surface geop. height", "-",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .                "once", zsto,zout)
+c
+c        CALL histdef(nid_hf, "aire", "Grid area", "-",
+c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+c    .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_hf, "tsol", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_hf, "psol", "Surface Pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         print*,'ATTENTION METTRE AVE(X) POUR LES PRECIPS'
+
+         CALL histdef(nid_hf, "rain", "Precipitation", "mm/d",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_hf, "u850", "Zonal wind 850mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         CALL histdef(nid_hf, "v850", "Meridional wind 850mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_hf, "u500", "Zonal wind 500mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         CALL histdef(nid_hf, "v500", "Meridional wind 500mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         CALL histdef(nid_hf, "u200", "Zonal wind 200mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         CALL histdef(nid_hf, "v200", "Meridional wind 200mb", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+         CALL histdef(nid_hf, "phi500", "Geopotentiel à 500mb", "m2/s2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+
+c
+         CALL histend(nid_hf)
+
+      endif ! ok_hf
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histins.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histins.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histins.h	(revision 428)
@@ -0,0 +1,235 @@
+      IF (ok_instan) THEN
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+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,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         CALL histbeg("histins", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime,
+     .                 nhori, nid_ins)
+         write(*,*)'Inst ', itau_phy, zjulian
+         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
+         zout = dtime * ecrit_ins
+C
+         CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_ins, "aire", "Grid area", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+        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, "t2m", "Temperature 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "q2m", "Specific humidity 2m", "Kg/Kg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "v10m", "Vent meridien 10m", "m/s",
+     .                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, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "cdrh", "Heat drag coef.", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow", "Snow fall", "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "snow_mass", "Snow Mass", "kg/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "topl", "OLR", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "evap", "Evaporation", "kg/s",
+     .                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)
+CXXX
+         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,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "geop", "Geopotential height", "m",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
+     .                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
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histmth.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histmth.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ini_histmth.h	(revision 428)
@@ -0,0 +1,489 @@
+      IF (ok_mensuel) THEN
+c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+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,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+         CALL histbeg("histmth.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+     .                 nhori, nid_mth)
+         write(*,*)'Mensuel ', itau_phy, zjulian
+         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
+         zout = dtime * ecrit_mth
+c
+         CALL histdef(nid_mth, "phis", "Surface geop. height", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "once",  zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "t2m", "Temperature 2m", "K",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "q2m", "Specific humidity 2m", "Kg/Kg",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "u10m", "Vent zonal 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "v10m", "Vent meridien 10m", "m/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "qsol", "Surface humidity", "mm",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "precip", "Precipitation Totale liq+sol", 
+     .                "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "snow", "Snow fall", "kg/s",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "snow_mass", "Snow Mass", "kg/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "evap", "Evaporation", "kg/s",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                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,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldq", "Cloud liquid water path", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+cKE43
+      IF (iflag_con .GE. 3) 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, "clwcon", "Cloud Liquid water content"
+     .                , "kg/kg",
+     .                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, "ducon", "Convection du", "m/s2",
+     .                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,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+
+         CALL histdef(nid_mth, "ratqs", "RATQS"," ",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "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,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "SW radiation dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlw0", "LW radiation dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtec", "Cinetic dissip dT", "K/s",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                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,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         ENDIF
+C
+         IF (ok_orolf) THEN
+         CALL histdef(nid_mth, "dulif", "Orography dU", "m/s2",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         ENDIF
+C
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "-",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         if (nqmax.GE.3) THEN
+         DO iq=1,nqmax-2
+         IF (iq.LE.99) THEN
+         WRITE(str2,'(i2.2)') iq
+         CALL histdef(nid_mth, "trac"//str2, "Tracer No."//str2, "-",
+     .                iim,jjmp1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+         ENDIF
+         ENDDO
+         ENDIF
+c
+cKE43
+      IF (iflag_con.GE.3) 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)
+cccIM
+         CALL histdef(nid_mth, "SWupTOA", "SWup at TOA","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "SWupSFC", "SWup at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "SWdnTOA", "SWdn at TOA","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "SWdnSFC", "SWdn at surface","W/m2",
+     .                iim,jjmp1,nhori, 1,1,1,-99,
+     .                32, "ave(X)", zsto,zout)
+c
+      ENDIF
+c34EK
+         CALL histend(nid_mth)
+c
+         ndex2d = 0
+         ndex3d = 0
+c
+      ENDIF ! fin de test sur ok_mensuel
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inifis.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inifis.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/inifis.F	(revision 428)
@@ -0,0 +1,69 @@
+      SUBROUTINE inifis(ngrid,nlayer,
+     $           punjours,
+     $           pdayref,ptimestep,
+     $           plat,plon,parea,
+     $           prad,pg,pr,pcpp)
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Initialisation for the physical parametrisations of the LMD 
+c   martian atmospheric general circulation modele.
+c
+c   author: Frederic Hourdin 15 / 10 /93
+c   -------
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    pdayref               Day of reference for the simulation
+c    firstcall             True at the first call
+c    lastcall              True at the last call
+c    pday                  Number of days counted from the North. Spring
+c                          equinoxe.
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+ 
+#include "dimensions.h"
+#include "dimphy.h"
+
+      REAL prad,pg,pr,pcpp,punjours
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(klon)
+      INTEGER pdayref
+ 
+      REAL ptimestep
+ 
+      IF (nlayer.NE.klev) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'klev   = ',klev
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.klon) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'klon   = ',klon
+         STOP
+      ENDIF
+
+      RETURN
+9999  STOP'Cette version demande les fichier rnatur.dat et surf.def'
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/initphysto.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/initphysto.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/initphysto.F	(revision 428)
@@ -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, idayref
+      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
+      idayref = dayref
+      CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+      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(:,1), jjm+1, zx_lat(1,:),
+     .             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/IPSL-CM4_v1x1/libf/phylmd/initrrnpb.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/initrrnpb.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/initrrnpb.F	(revision 428)
@@ -0,0 +1,119 @@
+      SUBROUTINE  initrrnpb(ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: initialisation des constantes des traceurs
+CAA Revison pour le controle avec la temperature du sol
+cAA
+CAA   it = 1 radon ss controle de ts
+cAA   it = 2 plomb ss controle de ts  
+c======================================================================
+c Arguments:
+c nbtr------input-I- nombre de vrais traceurs (sans l'eau)
+c ftsol-------input-R- Temperature du sol (Kelvin)
+c pctsrf-----input-R-  Nature de sol (pourcentage de sol)
+c masktr---output-R- Masque reservoir de sol traceur (1 = reservoir)
+c fshtr----output-R- Flux surfacique de production dans le sol
+c hsoltr---output-R- Epaisseur du reservoir de sol
+c tautr----output-R- Constante de decroissance du traceur
+c vdeptr---output-R- Vitesse de depot sec dans la couche Brownienne
+c scavtr---output-R- Coefficient de lessivage
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "indicesol.h"
+c======================================================================
+C
+      INTEGER i, it
+      REAL pctsrf(klon,nbsrf) !Pourcentage de sol (f(nature du sol))
+      REAL ftsol(klon,nbsrf)  ! Temperature du sol pour le controle Rn
+c                             ! le cas echeant
+      REAL masktr(klon,nbtr)  ! Masque de l'echange avec la surface
+c                                 (possible => 1 )
+      REAL fshtr(klon,nbtr)  ! Flux surfacique dans le reservoir de sol
+      REAL hsoltr(nbtr)      ! Epaisseur equivalente du reservoir de sol
+      REAL tautr(nbtr)       ! Constante de decroissance radioactive
+      REAL vdeptr(nbtr)      ! Vitesse de depot sec dans la couche Brownienne
+      REAL scavtr(nbtr)      ! Coefficient de lessivage
+      REAL s
+C
+      WRITE(*,'(''PASSAGE initrrnpb ...'',$)')
+      print*,'nbtr= ',nbtr
+      print*,'nbsrf= ',nbsrf
+      print*,'klon= ',klon
+C
+C Puis les initialisation specifiques a chaque traceur (pour le moment, Rn222)
+C
+C
+C Radon it = 1
+c
+      IF ( nbtr .LE. 0 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 1
+      s = 1.E4  !  Source: atome par m2
+      hsoltr(it) = 0.1      ! Hauteur equivalente du reservoir : 
+c                              1 m * porosite 0.1
+      tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+cAA
+c      tautr(it) = 4.765E55  ! Decroissance du radon,infinie
+cAA
+      vdeptr(it) = 0. ! Pas de depot sec pour le radon
+      scavtr(it) = 0. ! Pas de lessivage pour le radon
+
+      print*, '-------------- SOURCE DU RADON ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+
+      DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,3)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it) * pctsrf(i,3)
+cAA
+cAA quelques tests
+cAA POur l'instant le pctsrf(i,3) = 1.0 
+cAA lorsqu'il ya de la terre mias ne prend aucune autre valeur
+cAA il n'est donc pas necessaire de multiplier fshtr par pctsrf
+cAA 
+c       print*, '------------------------------------------ '
+c        print*, 'masktr(',i,it,')= ',masktr(i,it)
+c        print*, 'fshtr(',i,it,')= ',fshtr(i,it)
+c        print*, 'pctsrf(',i,',1)= ',pctsrf(i,1)
+c        print*, 'pctsrf(',i,',2)= ',pctsrf(i,2)
+c        print*, 'pctsrf(',i,',3)= ',pctsrf(i,3)
+c        print*, 'pctsrf(',i,',4)= ',pctsrf(i,4)
+c        print*, 's = ',s
+c        print*, '------------------------------------------ '
+
+      END DO
+C
+C 210Pb it = 2
+C
+      IF ( nbtr .LE. 1 ) STOP 'initrrnpb pas glop pas glop' 
+      it = 2
+      s = 0. !  Pas de source !!!
+      hsoltr(it) = 10.     ! Hauteur equivalente du reservoir 
+c                              a partir duquel le
+c                              depot Brownien a lieu
+      tautr(it) = 1.028E9 ! Decroissance du Pb210, secondes
+      vdeptr(it) = 1.E-3 ! 1 mm/s pour le 210Pb
+      scavtr(it) =  .5   ! Lessivage du Pb210
+      DO i = 1,klon
+        masktr(i,it) = 1. ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+      END DO
+      print*, '-------------- SOURCE DU PLOMB ------------------------ '
+      print*,'it = ',it
+      print*,'Source : ', s
+      print*,'Hauteur equivalente du reservoir : ',hsoltr(it) 
+      print*,'Decroissance (s): ', tautr(it)
+      print*,'Vitesse de depot sec: ',vdeptr(it) 
+      print*,'Facteur de lessivage: ',scavtr(it)
+c
+      WRITE(*,*) 'initialisation rnpb ok'
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/interface_surf.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/interface_surf.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/interface_surf.F90	(revision 428)
@@ -0,0 +1,2575 @@
+! $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
+!! pour simuler la fonte des glaciers antarctiques
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: coeff_iceberg
+  real, save                              :: surf_maille 
+  real, save                              :: cte_flux_iceberg = 6.3e7
+  integer, save                           :: num_antarctic = 1
+!!$
+  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, dimension(klon):: qsol_new
+!!  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/100., radsol, &
+     &  evap, fluxsens, fluxlat, &              
+     &  tsol_rad, tsurf_new, alb_new, alblw, &
+     &  emis_new, z0_new, dflux_l, dflux_s, qsol_new)
+
+!  
+! ajout de la contribution du relief
+!  
+      z0_new = SQRT(z0_new**2+rugoro**2)
+!
+! mise a jour de l'humidite saturante calculee par ORCHIDEE
+      qsol(1:knon) = qsol_new(1:knon)
+
+    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, qsurf)
+
+  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
+!   qsurf        saturated air moisture at surface
+
+! 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, qsurf
+  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):: snow
+  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
+
+#include "temps.inc"
+
+  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)
+          jj = int((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+      correspond(ij,jj) = igrid
+    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 (pctsrf(ireal, is_ter) > EPSFRA) then
+          jj = int((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+            neighbours(igrid, i) = correspond(ij, jj)
+        endif
+      enddo
+    enddo
+
+!
+!  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+itau_phy-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, ps, &
+     & 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+itau_phy, 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, ps, &
+     & 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,knindex)
+    bidule=0.
+    bidule(1:knon)=coastalflow(1:knon)
+    call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jjm,knindex)
+    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 temps de 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_calv
+  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
+  integer :: idayref, itau_w
+#include "param_cou.h"
+#include "inc_cpl.h"
+#include "temps.inc"
+!
+! 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
+!
+    idayref = day_ini
+    CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+    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(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+       & itau_phy,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(:,1),jjm+1,zx_lat(1,:),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)
+
+! pour simuler la fonte des glaciers antarctiques
+! 
+    surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1))
+    ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error)
+    if (error /= 0) then
+      abort_message='Pb allocation variable coeff_iceberg'
+      call abort_gcm(modname,abort_message,1)
+    endif
+    open (12,file='flux_iceberg',form='formatted',status='old')
+    read (12,*) coeff_iceberg
+    close (12)
+    num_antarctic = max(1, count(coeff_iceberg > 0))
+    
+    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
+      itau_w = itau_phy + itime
+      CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs)
+      CALL histwrite(nidcs,cl_read(4),itau_w,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
+!
+! pour simuler la fonte des glaciers antarctiques
+!
+!$$$        wri_rain = wri_rain      &
+!$$$      &     + coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)
+      wri_calv = coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille)
+!
+! 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',itau_w,wri_taux,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tauyn',itau_w,wri_tauy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,'tmp_lat',itau_w,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),itau_w,wri_sol_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(2),itau_w,wri_sol_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(3),itau_w,wri_nsol_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(4),itau_w,wri_nsol_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(5),itau_w,wri_fder_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(6),itau_w,wri_evap_ice,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(7),itau_w,wri_evap_sea,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(8),itau_w,wri_rain,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(9),itau_w,wri_snow,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(10),itau_w,wri_rcoa,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(11),itau_w,wri_rriv,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(12),itau_w,wri_calv,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(13),itau_w,wri_tauxx,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(14),itau_w,wri_tauyy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(15),itau_w,wri_tauzz,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(16),itau_w,wri_tauxx,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(17),itau_w,wri_tauyy,iim*(jjm+1),ndexct)
+      CALL histwrite(nidct,cl_writ(18),itau_w,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_calv, 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/IPSL-CM4_v1x1/libf/phylmd/minmaxqfi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/minmaxqfi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/minmaxqfi.F	(revision 428)
@@ -0,0 +1,30 @@
+      SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+      IMPLICIT none
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+      CHARACTER*(*) comment
+      real qmin,qmax
+      real zq(klon,klev)
+
+      INTEGER jadrs(klon), jbad, k, i
+
+      DO k = 1, klev
+         jbad = 0
+         DO i = 1, klon
+         IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+         IF (jbad.GT.0) THEN
+         PRINT*, comment
+         DO i = 1, jbad
+            PRINT*, "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+         ENDDO
+         ENDIF
+      ENDDO
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/mpiclim.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/mpiclim.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/mpiclim.h	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/newmicro.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/newmicro.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/newmicro.F	(revision 428)
@@ -0,0 +1,192 @@
+      SUBROUTINE newmicro (paprs, pplay,ok_newmicro,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "nuage.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_chaud
+cc      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)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+ccc      PARAMETER (nexpo=1)
+
+c -- sb:
+      logical ok_newmicro
+c     parameter (ok_newmicro=.FALSE.)
+      real rel, tc, rei, zfiwp
+      real k_liq, k_ice0, k_ice, DF
+      parameter (k_liq=0.0903, k_ice0=0.005) ! units=m2/g
+      parameter (DF=1.66) ! diffusivity factor
+c sb --
+
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      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)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+
+         if (ok_newmicro) then
+
+c -- liquid/ice cloud water paths:
+
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+
+         zflwp = 1000.*(1.-zfice)*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+         zfiwp = 1000.*zfice*pqlwp(i,k)/pclc(i,k)
+     :          *(paprs(i,k)-paprs(i,k+1))/RG
+
+c -- effective cloud droplet radius (microns):
+
+c for liquid water clouds: 
+         rel = rad_chaud
+
+c for ice clouds: as a function of the ambiant temperature
+c [formula used by Iacobellis and Somerville (2000), with an 
+c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+c consistent with observations of Heymsfield et al. 1986]:
+         tc = t(i,k)-273.15
+         rei = 0.71*tc + 61.29 
+         if (tc.le.-81.4) rei = 3.5 
+
+c -- cloud optical thickness :
+
+c [for liquid clouds, traditional formula, 
+c  for ice clouds, Ebert & Curry (1992)] 
+
+         if (zflwp.eq.0.) rel = 1. 
+         if (zfiwp.eq.0. .or. rei.le.0.) rei = 1. 
+         pcltau(i,k) = 3.0/2.0 * ( zflwp/rel )
+     .             + zfiwp * (3.448e-03  + 2.431/rei)
+
+c -- cloud infrared emissivity:
+
+c [the broadband infrared absorption coefficient is parameterized
+c  as a function of the effective cld droplet radius]
+
+c Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+         k_ice = k_ice0 + 1.0/rei
+
+         pclemi(i,k) = 1.0
+     .      - EXP( - coef_chau*zflwp - DF*k_ice*zfiwp )
+
+         endif ! ok_newmicro
+
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nflxtr.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nflxtr.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nflxtr.F	(revision 428)
@@ -0,0 +1,162 @@
+      SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,
+     .                 pplay,paprs,x,dx) 
+      IMPLICIT NONE 
+c=====================================================================
+c Objet : Melange convectif de traceurs a partir des flux de masse 
+c Date : 13/12/1996 -- 13/01/97
+c Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+c         Brinkop et Sausen (1996) et Boucher et al. (1996).
+c ATTENTION : meme si cette routine se veut la plus generale possible, 
+c             elle a herite de certaines notations et conventions du 
+c             schema de Tiedtke (1993). 
+c --En particulier, les couches sont numerotees de haut en bas !!!
+c   Ceci est valable pour les flux
+c   mais pas pour les entrees x, pplay, paprs !!!!
+c --pmfu est positif, pmfd est negatif 
+c --Tous les flux d'entrainements et de detrainements sont positifs 
+c   contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+c=====================================================================
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOECUMF.h" 
+c
+      REAL pdtime
+c--les flux sont definis au 1/2 niveaux
+c--pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+      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 pplay(klon,klev)    ! pression aux couches (bas en haut)
+      REAL paprs(klon,klev+1)  ! pression aux 1/2 couches (bas en haut)
+      REAL x(klon,klev)        ! q de traceur (bas en haut) 
+      REAL dx(klon,klev)     ! tendance de traceur  (bas en haut)
+c
+c--flux convectifs mais en variables locales
+      REAL zmfu(klon,klev+1) 
+      REAL zmfd(klon,klev+1) 
+      REAL zen_u(klon,klev) 
+      REAL zde_u(klon,klev)
+      REAL zen_d(klon,klev) 
+      REAL zde_d(klon,klev)
+      real zmfe
+c
+c--variables locales      
+c--les flux de x sont definis aux 1/2 niveaux 
+c--xu et xd sont definis aux niveaux complets
+      REAL xu(klon,klev)        ! q de traceurs dans le panache montant
+      REAL xd(klon,klev)        ! q de traceurs dans le panache descendant
+      REAL zmfux(klon,klev+1)   ! flux de x dans le panache montant
+      REAL zmfdx(klon,klev+1)   ! flux de x dans le panache descendant
+      REAL zmfex(klon,klev+1)   ! flux de x dans l'environnement 
+      INTEGER i, k 
+      REAL zmfmin
+      PARAMETER (zmfmin=1.E-10)
+
+c =========================================
+c
+c
+c   Extension des flux UP et DN sur klev+1 niveaux
+c =========================================
+      do k=1,klev
+         do i=1,klon
+            zmfu(i,k)=pmfu(i,k)
+            zmfd(i,k)=pmfd(i,k)
+         enddo
+      enddo
+      do i=1,klon
+         zmfu(i,klev+1)=0.
+         zmfd(i,klev+1)=0.
+      enddo
+
+c--modif pour diagnostiquer les detrainements
+c =========================================
+c   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+      do k=1, klev
+         do i=1, klon
+            zen_d(i,k)=pen_d(i,k)
+            zde_u(i,k)=pde_u(i,k)
+            zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+            zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+         enddo 
+      enddo 
+c
+c--calcul des flux dans le panache montant
+c =========================================
+c
+c Dans la premiere couche, on prend q comme valeur de qu
+c
+      do i=1, klon
+         zmfux(i,1)=0.0 
+      enddo
+c
+c Autres couches
+      do k=1,klev
+         do i=1, klon
+            if ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+               xu(i,k)=x(i,k)
+            else
+               xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))
+     s               /(zmfu(i,k+1)+zde_u(i,k))
+            endif
+            zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+         enddo
+      enddo
+c
+c--calcul des flux dans le panache descendant
+c =========================================
+c   
+      do i=1, klon
+         zmfdx(i,klev+1)=0.0 
+      enddo
+c
+      do k=klev,1,-1
+         do i=1, klon
+            if ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+               xd(i,k)=x(i,k)
+            else
+               xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k)) /
+     .               (zmfd(i,k)-zde_d(i,k))
+            endif
+            zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+         enddo
+      enddo
+c
+c--introduction du flux de retour dans l'environnement
+c =========================================
+c
+      do k=2, klev
+         do i=1, klon
+            zmfe=-zmfu(i,k)-zmfd(i,k)
+            if (zmfe.le.0.) then
+               zmfex(i,k)= zmfe*x(i,k)
+            else
+               zmfex(i,k)= zmfe*x(i,k-1)
+            endif
+         enddo
+      enddo
+
+      do i=1, klon
+         zmfex(i,1)=0.
+         zmfex(i,klev+1)=0.
+      enddo
+c
+c--calcul final des tendances
+c
+      do k=1, klev
+         do i=1, klon
+            dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*
+     .                      ( zmfux(i,k) - zmfux(i,k+1) +
+     .                        zmfdx(i,k) - zmfdx(i,k+1) +
+     .                        zmfex(i,k) - zmfex(i,k+1) )
+         enddo
+      enddo
+c
+      return 
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nuage.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nuage.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nuage.F	(revision 428)
@@ -0,0 +1,311 @@
+      SUBROUTINE nuage (paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "nuage.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_chaud
+ccc      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)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+ccc      PARAMETER (nexpo=1)
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      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)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
+     .                   diafra,dialiq)
+      IMPLICIT none
+c
+c Laurent Li (LMD/CNRS), le 12 octobre 1998
+c                        (adaptation du code ECMWF)
+c
+c Dans certains cas, le schema pronostique des nuages n'est
+c pas suffisament performant. On a donc besoin de diagnostiquer
+c ces nuages. Je dois avouer que c'est une frustration.
+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)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+c
+c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+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 ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon ! pour traiter les enclumes
+      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(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      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
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         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 * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)
+     .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         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/IPSL-CM4_v1x1/libf/phylmd/nuage.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nuage.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/nuage.h	(revision 428)
@@ -0,0 +1,3 @@
+      REAL rad_froid, rad_chau1, rad_chau2
+
+      common /nuagecom/ rad_froid,rad_chau1, rad_chau2
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/o3cm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/o3cm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/o3cm.F	(revision 428)
@@ -0,0 +1,58 @@
+      SUBROUTINE o3cm (amb, bmb, sortie, ntab)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ce programme calcule le contenu en ozone "sortie"
+c        (unite: cm.atm) entre deux niveaux "amb" et "bmb" (unite: mb)
+c        "ntab" est le nombre d'intervalles pour l'integration, sa
+c        valeur depend bien sur de l'epaisseur de la couche et de
+c        la precision qu'on souhaite a obtenir
+c======================================================================
+      REAL amb, bmb, sortie
+      INTEGER ntab
+c======================================================================
+      INTEGER n
+      REAL xtab(500), xa, xb, ya, yb, xincr
+c======================================================================
+      external mbtozm
+c======================================================================
+c la fonction en ligne w(x) donne le profil de l'ozone en fonction
+c de l'altitude (unite: cm.atm / km)
+c (Green 1964, Appl. Opt. 3: 203-208)
+      REAL wp, xp, h, x, w, con
+      PARAMETER (wp=0.218, xp=23.25, h=4.63, con=1.0)
+      w(x) = wp/h * EXP((x-xp)/h)/ (con+EXP((x-xp)/h))**2
+c======================================================================
+      IF (ntab .GT. 499) STOP 'BIG ntab'
+      xincr = (bmb-amb) / FLOAT(ntab)
+      xtab(1) = amb
+      DO n = 2, ntab
+         xtab(n) = xtab(n-1) + xincr
+      ENDDO
+      xtab(ntab+1) = bmb
+      sortie = 0.0
+      DO n = 1, ntab
+         CALL mbtozm(xtab(n), xa)
+         CALL mbtozm(xtab(n+1), xb)
+         xa = xa / 1000.
+         xb = xb / 1000.
+         ya = w(xa)
+         yb = w(xb)
+         sortie = sortie + (ya+yb)/2.0 * ABS(xb-xa)
+      ENDDO
+      RETURN
+      END
+      SUBROUTINE mbtozm(rmb,zm)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c Objet: transformer une hauteur de mb (rmb) en metre (zm)
+c======================================================================
+      REAL rmb, zm
+c======================================================================
+      REAL gama, tzero, pzero, g, r
+      PARAMETER (gama=6.5e-3, tzero=288., pzero=1013.25)
+      PARAMETER (g=9.81, r=287.0)
+      zm = tzero/gama * ( 1.-(rmb/pzero)**(r*gama/g) )
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.F	(revision 428)
@@ -0,0 +1,665 @@
+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'
+      cl_writ(12)='COCALVIN'
+c$$$      cl_writ(13)='COZOTAUX'
+c$$$      cl_writ(14)='COZOTAUV'
+c$$$      cl_writ(15)='COMETAUY'
+c$$$      cl_writ(16)='COMETAUU'
+      cl_writ(13)='COTAUXXU'
+      cl_writ(14)='COTAUYYU'
+      cl_writ(15)='COTAUZZU'
+      cl_writ(16)='COTAUXXV'
+      cl_writ(17)='COTAUYYV'
+      cl_writ(18)='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'
+      cl_f_writ(18)='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, 
+     $    calving, 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)
+      REAL calving(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,*) 'last  ', last
+      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')
+            WRITE(*,*) 'Opening FILE ', file_unit(jn), ' '
+     $          , file_name(jn) 
+            REWIND(file_unit(jn))
+          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) 
+            IF (jf.eq.12)
+     $          CALL locwrite(cl_writ(jf),calving, imjm,
+     $          file_unit_field(jf), ierror) 
+c$$$            IF (jf.eq.13)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.1')
+c$$$     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.15)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.16)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
+c$$$     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.13)
+     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.14)
+     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.15)
+     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.16)
+     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.17)
+     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.18)
+     $          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)
+          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn),kt,calving,info)
+c$$$          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
+c$$$          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
+c$$$          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
+c$$$          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
+          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
+          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
+          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
+          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
+          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
+          IF (jn.eq.18) 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
+      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/IPSL-CM4_v1x1/libf/phylmd/oasis.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.h	(revision 428)
@@ -0,0 +1,14 @@
+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/IPSL-CM4_v1x1/libf/phylmd/oasis.true
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.true	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/oasis.true	(revision 428)
@@ -0,0 +1,599 @@
+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'
+      cl_writ(12)='COCALVIN'
+c$$$      cl_writ(13)='COZOTAUX'
+c$$$      cl_writ(14)='COZOTAUV'
+c$$$      cl_writ(15)='COMETAUY'
+c$$$      cl_writ(16)='COMETAUU'
+      cl_writ(13)='COTAUXXU'
+      cl_writ(14)='COTAUYYU'
+      cl_writ(15)='COTAUZZU'
+      cl_writ(16)='COTAUXXV'
+      cl_writ(17)='COTAUYYV'
+      cl_writ(18)='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'
+      cl_f_writ(18)='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, 
+     $    calving, 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)
+      REAL calving(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,*) 'last  ', last
+      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')
+            WRITE(*,*) 'Opening FILE ', file_unit(jn), ' '
+     $          , file_name(jn) 
+            REWIND(file_unit(jn))
+          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) 
+            IF (jf.eq.12)
+     $          CALL locwrite(cl_writ(jf),calving, imjm,
+     $          file_unit_field(jf), ierror) 
+c$$$            IF (jf.eq.13)
+c$$$     $          CALL locwrite(cl_writ(jf),tauxu, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.1')
+c$$$     $          CALL locwrite(cl_writ(jf),tauxv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.15)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyv, imjm,
+c$$$     $          file_unit_field(jf),ierror) 
+c$$$            IF (jf.eq.16)
+c$$$     $          CALL locwrite(cl_writ(jf),tauyu, imjm,
+c$$$     $          file_unit_field(jf), ierror) 
+            IF (jf.eq.13)
+     $          CALL locwrite(cl_writ(jf),tauxx_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.14)
+     $          CALL locwrite(cl_writ(jf),tauyy_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.15)
+     $          CALL locwrite(cl_writ(jf),tauzz_u, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.16)
+     $          CALL locwrite(cl_writ(jf),tauxx_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.17)
+     $          CALL locwrite(cl_writ(jf),tauyy_v, imjm,
+     $          file_unit_field(jf),ierror)
+            IF (jf.eq.18)
+     $          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)
+          IF (jn.eq.12) CALL CLIM_Export(cl_writ(jn),kt,calving,info)
+c$$$          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxu, info)
+c$$$          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauxv, info)
+c$$$          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauyv, info)
+c$$$          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauyu, info)
+          IF (jn.eq.13) CALL CLIM_Export(cl_writ(jn), kt, tauxx_u, info)
+          IF (jn.eq.14) CALL CLIM_Export(cl_writ(jn), kt, tauyy_u, info)
+          IF (jn.eq.15) CALL CLIM_Export(cl_writ(jn), kt, tauzz_u, info)
+          IF (jn.eq.16) CALL CLIM_Export(cl_writ(jn), kt, tauxx_v, info)
+          IF (jn.eq.17) CALL CLIM_Export(cl_writ(jn), kt, tauyy_v, info)
+          IF (jn.eq.18) 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/IPSL-CM4_v1x1/libf/phylmd/orbite.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/orbite.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/orbite.F	(revision 428)
@@ -0,0 +1,319 @@
+c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+c Objet: pour un jour donne, calculer la longitude vraie de la terre
+c        (par rapport au point vernal-21 mars) dans son orbite solaire
+c        calculer aussi la distance terre-soleil (unite astronomique)
+c======================================================================
+c Arguments:
+c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+c                  vernal (21 mars) en degres
+c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+c======================================================================
+#include "YOMCST.h"
+C
+C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)
+     .     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)
+     .     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)
+     .         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)
+     .         +13.0/12.0*xee*SIN(3.0*ranm)
+c
+      anv=ranv/pir
+      longi=anv+xl
+C
+      dist = (1-R_ecc*R_ecc)
+     .      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END
+c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+c======================================================================
+c Arguments:
+c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+c                   solaire a partir de l'equinoxe de printemps (degre)
+c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+c                   par 24 heures (unite en fraction de 0 a 1)
+c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+c                   la journee (0 a 1)
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+c
+      IF ( lat .GE. (pi_local/2.+lat_sun)
+     .    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)
+     .          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+c
+      frac(i) = omega / pi_local
+c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)
+     .          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,
+     s                  pmu0,frac)
+      IMPLICIT none
+c=============================================================
+c Auteur : O. Boucher (LMD/CNRS)
+c          d'apres les routines zenith et angle de Z.X. Li 
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi----INPUT : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime---INPUT : temps universel en fraction de jour
+c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c================================================================
+      real longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+c omega : heure en radian du coucher de soleil 
+c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+c================================================================
+c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+c
+      DO i = 1, klon
+c
+      latr = lat(i) * pi_local / 180.
+c
+c--pose probleme quand lat=+/-90 degres
+c
+c      omega = -TAN(latr)*TAN(lat_sun)
+c      omega = ACOS(omega)
+c      IF (latr.GE.(pi_local/2.+lat_sun)
+c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+c         omega = 0.0       ! nuit polaire
+c      ENDIF
+c      IF (latr.GE.(pi_local/2.-lat_sun)
+c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+c         omega = pi_local  ! journee polaire
+c      ENDIF
+c
+c--remplace par cela (le cas par defaut est different)
+c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)
+     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.
+     .    latr.GT.(-pi_local/2.+lat_sun).AND.
+     .    latr.LT.(pi_local/2.-lat_sun).AND.
+     .    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega
+     .                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) + 
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)        
+      ENDIF
+c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+c
+c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)
+      ENDIF 
+c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +
+     .           COS(latr)*COS(lat_sun)*
+     .           (SIN(omegafin)-SIN(omegadeb))/
+     .           (omegafin-omegadeb)
+c
+      ENDIF
+c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+c
+      ENDIF   !---comparaison omega1 et omega2
+c
+      ENDDO
+c
+      END
+c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,
+     s                   pmu0, fract)
+      IMPLICIT none
+c
+c Auteur(s): Z.X. Li (LMD/ENS)
+c
+c Objet: calculer le cosinus de l'angle zenithal du soleil en
+c        connaissant la declinaison du soleil, la latitude et la
+c        longitude du point sur la terre, et le temps universel
+c
+c Arguments d'entree:
+c     longi  : declinaison du soleil (en degres)
+c     gmtime : temps universel en second qui varie entre 0 et 86400
+c     lat    : latitude en degres
+c     long   : longitude en degres
+c Arguments de sortie:
+c     pmu0   : cosinus de l'angle zenithal
+c
+c====================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+c
+      incl=R_incl * zpir
+c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+c--initialisation a la nuit
+c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+c
+c 1 degre en longitude = 240 secondes en temps
+c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)
+     .           + cos(lat(n)*zpir) * cos(lat_sun)
+     .           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/orografi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/orografi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/orografi.F	(revision 428)
@@ -0,0 +1,1762 @@
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+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 t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature             
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(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, kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+         pvstr(i)        = pvstr(i)
+     .                    +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE orodrag( nlon,nlev 
+     i                 , kgwd, kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+
+      implicit none
+
+c
+c
+c**** *gwdrag* - does the gravity wave parametrization.
+c
+c     purpose.
+c     --------
+c
+c          this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves
+c
+c**   interface.
+c     ----------
+c          called from *callpar*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c      implicit logical (l)
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+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),
+     *      pvom(nlon,nlev),
+     *      pulow(klon),
+     *      pvlow(klon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     $       ztauf(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)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+  200 continue
+c
+c
+c
+      call orosetup
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress
+     *    ( nlon  , nlev
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
+c
+c
+c*         5.      compute tendencies.
+c*                 -------------------
+c
+  500 continue
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+      ilevp1=klev+1
+c
+c
+      do 524 jk=1,klev
+c
+c
+      do 523 jl=1,kgwd
+      ji=kdx(jl)
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c controle des overshoots:
+c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c fin du controle des overshoots
+c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c simplement oppose au vent
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c  projection dans la direction de l'axe principal de l'orographie
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c     pte(ji,jk)=zdtdt(ji)
+c
+c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+c
+      pte(ji,jk)=0.0
+
+  523 continue
+
+  524 continue
+c
+c
+      return
+      end
+      SUBROUTINE orosetup
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgamma, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+c
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      implicit none
+c
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+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),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c     print *,' entree gwsetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+c
+      zcons1=1./rd
+cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).xor.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).xor.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).xor.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+c
+
+ 210  continue
+c
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define low-level flow
+c      ---------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define blocked flow
+c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+c
+c*******  setup orography axes and define plane of profiles  *******
+c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+c
+c  ************ define flow in plane of lowlevel stress *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c
+c*         2.2     brunt-vaisala frequency and density at half levels.
+c
+  220 continue
+c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*
+     *                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)
+     *                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+c
+c*         2.3     mean flow richardson number.
+c*                 and critical height for froude layer
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for the breaking
+c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,
+     *          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end
+      SUBROUTINE gwstress
+     *         (  nlon  , nlev
+     *         , ktest, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      implicit none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      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),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2
+     *    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+     *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+c
+      return
+      end
+      SUBROUTINE GWPROFIL
+     *         ( NLON, NLEV
+     *         , kgwd, kdx
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      implicit none
+C
+
+C
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      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), PTAU(NLON,NLEV+1)
+     
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+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)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      ilevh=KLEV/3
+C
+      DO 400 ji=1,kgwd
+      jl=kdx(ji)
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+  400 CONTINUE
+  
+C
+      DO 430 JK=KLEV,2,-1
+C
+C
+C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+C                 BLOCKING LAYER.
+  410 CONTINUE
+C
+      DO 411 ji=1,kgwd
+      jl=kdx(ji)
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+C          ENDIF
+C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+ 411  CONTINUE             
+C
+C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+C        
+C
+C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+C
+  420 CONTINUE
+C
+      DO 421 ji=1,kgwd
+      jl=kdx(ji)
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)
+     *                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+  421 CONTINUE
+C
+C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+C                 LEVEL
+C
+                          
+      DO 431 ji=1,kgwd
+      jl=kdx(ji)
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+      DO 530 ji=1,kgwd
+      jl=kdx(ji)
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+      DO 532 ji=1,kgwd
+      jl=kdx(ji)
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+ 532  CONTINUE    
+ 
+C  REORGANISATION IN THE STRATOSPHERE
+
+      DO 533 ji=1,kgwd
+      jl=kdx(ji)
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+ 533  CONTINUE
+
+C REORGANISATION IN THE TROPOSPHERE
+
+       DO 534 ji=1,kgwd
+       jl=kdx(ji)
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +
+     *                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP/ZDELPT
+
+       ENDIF
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+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 t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(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, ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL OROLIFT(klon,klev,ktest,
+     .            dtime,
+     .            papmh, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, ppic,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+         pvstr(i)        = pvstr(i)
+     .                    +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE OROLIFT( NLON,NLEV
+     I                 , KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, ppic
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+      implicit none
+C
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),
+     *      PVOL(NLON,NLEV),
+     *      PVOM(NLON,NLEV),
+     *      PULOW(NLON),
+     *      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),
+     *      PVM1(NLON,NLEV),
+     *      PTM1(NLON,NLEV),
+     *      PLAT(NLON),PMEA(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
+     *      PGEOM1(NLON,NLEV),
+     *      PAPHM1(NLON,NLEV+1)
+C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      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)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+C-----------------------------------------------------------------------
+C
+C*         1.1  INITIALIZATIONS
+C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)STOP
+      ZCONS1=1./RD
+      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).XOR.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+C     do 2011 jl=kidia,kfdia
+C     IF(KTEST(JL).EQ.1) THEN
+C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+C     ENDIF
+C2011 continue
+
+C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 223'
+
+C********************************************************************
+C
+C*     DEFINE LOW LEVEL FLOW
+C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)
+     *               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 CONTINUE
+C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      IF(LIFTHIGH)THEN
+C
+  500 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 500'
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PSIG        : VERTICAL COORDINATE TABLE
+C        NLEV        : NUMBER OF MODEL LEVELS
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C        ECMWF Research Department documentation of the IFS
+C
+C     AUTHOR.
+C     -------
+C        MARTIN MILLER             *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      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
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay(nlon/2,jk)/paprs(nlon/2,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay(nlon/2,jk)/paprs(nlon/2,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+C
+      GKLIFT=0.50
+      GVCRIT =0.0
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=1.E-12
+C
+      GTSEC=1.E-07
+C
+C      ----------------------------------------------------------------
+C
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ozonecm.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ozonecm.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/ozonecm.F	(revision 428)
@@ -0,0 +1,67 @@
+      SUBROUTINE ozonecm(rjour, rlat, paprs, o3)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+      REAL rlat(klon), paprs(klon,klev+1)
+      REAL o3(klon,klev)
+      REAL tozon, rjour, pi, pl
+      INTEGER i, k
+C----------------------------------------------------------
+      REAL field(klon,klev+1)
+      REAL ps
+      PARAMETER (ps=101325.0)
+      REAL an, unit, zo3q3
+      SAVE an, unit, zo3q3
+      REAL mu,gms, zslat, zsint, zcost, z, ppm, qpm, a
+      REAL asec, bsec, aprim, zo3a3
+C----------------------------------------------------------
+c         data an /365.25/   (meteo)
+      DATA an /360.00/
+      DATA unit /2.1415e-05/
+      DATA zo3q3 /4.0e-08/
+
+      pi = 4.0 * ATAN(1.0)
+      DO k = 1, klev
+      DO i = 1, klon
+      zslat = SIN(pi/180.*rlat(i))
+      zsint = SIN(2.*pi*(rjour+15.)/an)
+      zcost = COS(2.*pi*(rjour+15.)/an)
+      z = 0.0531+zsint*(-0.001595+0.009443*zslat) +
+     .  zcost*(-0.001344-0.00346*zslat) +
+     .  zslat**2*(.056222+zslat**2*(-.037609
+     . +.012248*zsint+.00521*zcost+.008890*zslat))
+      zo3a3 = zo3q3/ps/2.
+      z = z-zo3q3*ps
+      gms = z
+      mu = ABS(sin(pi/180.*rlat(i)))
+      ppm = 800.-(500.*zslat+150.*zcost)*zslat
+      qpm = 1.74e-5-(7.5e-6*zslat+1.7e-6*zcost)*zslat
+      bsec = 2650.+5000.*zslat**2
+      a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+      a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+      aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+      aprim = amax1(0.,aprim)
+      asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+      asec = AMAX1(0.0,asec)
+      aprim = gms-asec/(1.+(bsec/ps)**(3./2.))
+      pl = paprs(i,k)
+      tozon = aprim/(1.+3.*(ppm/pl)**2)+asec/(1.+(bsec/pl)**(3./2.))
+     .  + zo3a3*pl*pl
+      tozon = tozon / 9.81  ! en kg/m**2
+      tozon = tozon / unit  ! en kg/m**2  > u dobson (10e-5 m)
+      tozon = tozon / 1000. ! en cm
+      field(i,k) = tozon
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         field(i,klev+1) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         o3(i,k) = field(i,k) - field(i,k+1)
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/param_cou.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/param_cou.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/param_cou.h	(revision 428)
@@ -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 = 12)         ! 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/IPSL-CM4_v1x1/libf/phylmd/param_sipc.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/param_sipc.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/param_sipc.h	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/phyetat0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phyetat0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phyetat0.F	(revision 428)
@@ -0,0 +1,1262 @@
+c
+c $Header$
+c
+      SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm,solaire,
+     .            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, rnebcon, ratqs,clwcon)
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Lecture de l'etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat(klon), rlon(klon)
+      REAL co2_ppm
+      REAL solaire
+      REAL tsol(klon,nbsrf)
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL deltat(klon)
+      REAL qsol(klon,nbsrf)
+      REAL snow(klon,nbsrf)
+      REAL albe(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      REAL radsol(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,nbsrf)
+      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 fractint(klon)
+
+      REAL t_ancien(klon,klev), q_ancien(klon,klev)
+      real rnebcon(klon,klev),clwcon(klon,klev),ratqs(klon,klev)
+      LOGICAL ancien_ok
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+c
+      REAL xmin, xmax
+c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil 
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length), tabcntr0(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+c
+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
+        write(6,*)' Pb d''ouverture du fichier '//fichnom
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+c Lecture des parametres de controle:
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <controle> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <controle>'
+         CALL abort
+      ELSE
+c
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+c
+         cycle_diurne   = .FALSE.
+         soil_model     = .FALSE.
+         new_oliq       = .FALSE.
+         ok_orodr       = .FALSE.
+         ok_orolf       = .FALSE.
+         ok_limitvrai   = .FALSE.
+
+
+         IF( clesphy0(1).NE.tab_cntrl( 5 ) )  THEN
+             tab_cntrl( 5 ) = clesphy0(1)
+         ENDIF
+
+         IF( clesphy0(2).NE.tab_cntrl( 6 ) )  THEN
+             tab_cntrl( 6 ) = clesphy0(2)
+         ENDIF
+
+         IF( clesphy0(3).NE.tab_cntrl( 7 ) )  THEN
+             tab_cntrl( 7 ) = clesphy0(3)
+         ENDIF
+
+         IF( clesphy0(4).NE.tab_cntrl( 8 ) )  THEN
+             tab_cntrl( 8 ) = clesphy0(4)
+         ENDIF
+
+         IF( clesphy0(5).NE.tab_cntrl( 9 ) )  THEN
+             tab_cntrl( 9 ) = clesphy0( 5 )
+         ENDIF
+
+         IF( clesphy0(6).NE.tab_cntrl( 10 ) )  THEN
+             tab_cntrl( 10 ) = clesphy0( 6 )
+         ENDIF
+
+         IF( clesphy0(7).NE.tab_cntrl( 11 ) )  THEN
+             tab_cntrl( 11 ) = clesphy0( 7 )
+         ENDIF
+
+         IF( clesphy0(8).NE.tab_cntrl( 12 ) )  THEN
+             tab_cntrl( 12 ) = clesphy0( 8 )
+         ENDIF
+
+
+         dtime        = tab_cntrl(1)
+         radpas       = tab_cntrl(2)
+         co2_ppm      = tab_cntrl(3)
+         solaire      = tab_cntrl(4)
+         iflag_con    = tab_cntrl(5)
+         nbapp_rad    = tab_cntrl(6)
+
+
+         cycle_diurne    = .FALSE.
+         soil_model      = .FALSE.
+         new_oliq        = .FALSE.
+         ok_orodr        = .FALSE.
+         ok_orolf        = .FALSE.
+         ok_limitvrai    = .FALSE.
+
+         IF( tab_cntrl( 7) .EQ. 1. )    cycle_diurne  = .TRUE.
+         IF( tab_cntrl( 8) .EQ. 1. )       soil_model = .TRUE.
+         IF( tab_cntrl( 9) .EQ. 1. )         new_oliq = .TRUE.
+         IF( tab_cntrl(10) .EQ. 1. )         ok_orodr = .TRUE.
+         IF( tab_cntrl(11) .EQ. 1. )         ok_orolf = .TRUE.
+         IF( tab_cntrl(12) .EQ. 1. )     ok_limitvrai = .TRUE.
+
+      ENDIF
+
+      itau_phy = tab_cntrl(15)
+
+c
+c Lecture des latitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlon)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+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
+      ierr = NF_INQ_VARID (nid, "TS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <TS> est absent'
+         PRINT*, '          Mais je vais essayer de lire TS**'
+         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, "TS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <TS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <TS"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(tsol(i,nsrf),xmin)
+              xmax = MAX(tsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsol(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(tsol(i,1),xmin)
+            xmax = MAX(tsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            tsol(i,nsrf) = tsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture des temperatures du sol profond:
+c
+      DO nsrf = 1, nbsrf
+      DO isoil=1, nsoilmx
+      IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
+         PRINT*, "Trop de couches ou sous-mailles"
+         CALL abort
+      ENDIF
+      WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+      ierr = NF_INQ_VARID (nid, 'Tsoil'//str7, nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+         PRINT*, "          Il prend donc la valeur de surface"
+         DO i=1, klon
+             tsoil(i,isoil,nsrf)=tsol(i,nsrf)
+         ENDDO
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil,nsrf))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil,nsrf))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "Lecture echouee pour <Tsoil"//str7//">"
+            CALL abort
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+c Lecture de deltat (pour slab ocean seulement):
+c
+      ierr = NF_INQ_VARID (nid, "DELTAT", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <DELTAT> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, deltat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, deltat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Lecture echouee pour <DELTAT>"
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(deltat(i),xmin)
+         xmax = MAX(deltat(i),xmax)
+      ENDDO
+      PRINT*,'Ecart de la SST deltat:', xmin, xmax
+c
+c Lecture de l'humidite du sol:
+c
+      ierr = NF_INQ_VARID (nid, "QS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <QS> est absent'
+         PRINT*, '          Mais je vais essayer de lire QS**'
+         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, "QS"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <QS"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, qsol(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <QS"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(qsol(i,nsrf),xmin)
+              xmax = MAX(qsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Humidite du sol QS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <QS> est present'
+         PRINT*, '          J ignore donc les autres humidites QS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, qsol(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, qsol(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <QS>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(qsol(i,1),xmin)
+            xmax = MAX(qsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Humidite du sol <QS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            qsol(i,nsrf) = qsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de neige au sol:
+c
+      ierr = NF_INQ_VARID (nid, "SNOW", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <SNOW> est absent'
+         PRINT*, '          Mais je vais essayer de lire SNOW**'
+         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, "SNOW"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <SNOW"//str2//"> est absent"
+              CALL abort
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <SNOW"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(snow(i,nsrf),xmin)
+              xmax = MAX(snow(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <SNOW> est present'
+         PRINT*, '          J ignore donc les autres neiges SNOW**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, snow(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, snow(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <SNOW>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(snow(i,1),xmin)
+            xmax = MAX(snow(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <SNOW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      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
+      ierr = NF_INQ_VARID (nid, "RADS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RADS> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, radsol)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RADS>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+c
+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*,'rugosite <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:
+c
+      ierr = NF_INQ_VARID (nid, "AGESNO", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
+         PRINT*, '          Mais je vais essayer de lire AGESNO**'
+         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, "AGESNO"//str2, nvarid)
+           IF (ierr.NE.NF_NOERR) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,nsrf))
+#endif
+           IF (ierr.NE.NF_NOERR) THEN
+             PRINT*, "phyetat0: Lecture echouee pour <AGESNO"//str2//">"
+             CALL abort
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(agesno(i,nsrf),xmin)
+              xmax = MAX(agesno(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Age de la neige AGESNO**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <AGESNO> est present'
+         PRINT*, '          J ignore donc les autres AGESNO**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <AGESNO>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(agesno(i,1),xmin)
+            xmax = MAX(agesno(i,1),xmax)
+         ENDDO
+         PRINT*,'Age de la neige <AGESNO>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+      ierr = NF_INQ_VARID (nid, "ZMEA", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZMEA> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zmea)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZMEA>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSTD", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSTD> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zstd)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSTD>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZSIG", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZSIG> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zsig)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZSIG>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZGAM", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZGAM> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zgam)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZGAM>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZTHE", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZTHE> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zthe)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZTHE>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "ZPIC", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZPIC> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zpic)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZPIC>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+c
+      ierr = NF_INQ_VARID (nid, "ZVAL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <ZVAL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, zval)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <ZVAL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+c
+c
+      ierr = NF_INQ_VARID (nid, "RUGSREL", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUGSREL> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugsrel)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rugsrel)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RUGSREL>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rugsrel(i),xmin)
+         xmax = MAX(rugsrel(i),xmax)
+      ENDDO
+      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
+      ierr = NF_INQ_VARID (nid, "CLWCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         clwcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, clwcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, clwcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <CLWCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+c
+      ierr = NF_INQ_VARID (nid, "RNEBCON", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         rnebcon = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rnebcon)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, rnebcon)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RNEBCON>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+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
+      ierr = NF_INQ_VARID (nid, "RATQS", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ratqs = 0.
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ratqs)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, ratqs)
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <RATQS>"
+            CALL abort
+         ENDIF
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phyredem.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phyredem.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phyredem.F	(revision 428)
@@ -0,0 +1,720 @@
+c $Header$
+c
+      SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire,
+     .           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, rnebcon, ratqs, clwcon)
+      IMPLICIT none
+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 "dimphy.h"
+#include "netcdf.inc"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "temps.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      REAL dtime
+      INTEGER radpas
+      REAL rlat(klon), rlon(klon)
+      REAL co2_ppm
+      REAL solaire
+      REAL tsol(klon,nbsrf)
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL deltat(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 fder(klon)
+      REAL radsol(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      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)
+      real clwcon(klon,klev),rnebcon(klon,klev),ratqs(klon,klev)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+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 '//fichnom
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
+     .                       "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)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      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.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22,
+     .                        "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+c
+      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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon)
+#endif
+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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      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)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      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")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      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, "fder", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      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)
+#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
+      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,"AGESNO"//str2,NF_DOUBLE,1,idim2
+     $          ,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,"AGESNO"//str2,NF_FLOAT,1,idim2
+     $          ,nvarid)
+#endif
+            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)
+#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
+      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
+      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
+      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
+      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
+      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
+      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
+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_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,frugs(1,is_oce))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,frugs(1,is_oce))
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "CLWCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Eau liquide convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,clwcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,clwcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RNEBCON", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Nebulosite convective")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rnebcon)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rnebcon)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RATQS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Ratqs")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ratqs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ratqs)
+#endif
+c
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/physiq.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/physiq.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/physiq.F	(revision 428)
@@ -0,0 +1,2041 @@
+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,
+     .            omega, cufi, cvfi,
+     .            d_u, d_v, d_t, d_qx, d_ps)
+      USE ioipsl
+      USE histcom
+      USE writephys
+
+      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 nlon----input-I-nombre de points horizontaux
+c nlev----input-I-nombre de couches verticales
+c nqmax---input-I-nombre de traceurs (y compris vapeur d'eau) = 1
+c debut---input-L-variable logique indiquant le premier passage
+c lafin---input-L-variable logique indiquant le dernier passage
+c rjour---input-R-numero du jour de l'experience
+c gmtime--input-R-temps universel dans la journee (0 a 86400 s)
+c pdtphys-input-R-pas d'integration pour la physique (seconde)
+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 pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
+c pphis---input-R-geopotentiel du sol
+c paire---input-R-aire de chaque maille
+c presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+c u-------input-R-vitesse dans la direction X (de O a E) en m/s
+c v-------input-R-vitesse Y (de S a N) en m/s
+c t-------input-R-temperature (K)
+c qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
+c d_t_dyn-input-R-tendance dynamique pour "t" (K/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)
+c d_v-----output-R-tendance physique de "v" (m/s/s)
+c d_t-----output-R-tendance physique de "t" (K/s)
+c d_qx----output-R-tendance physique de "qx" (kg/kg/s)
+c d_ps----output-R-tendance physique de la pression au sol
+c======================================================================
+#include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+#include "dimphy.h"
+#include "regdim.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+#include "temps.h"
+c======================================================================
+      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
+      PARAMETER (ok_cvl=.TRUE.)
+      LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
+      PARAMETER (ok_gust=.FALSE.)
+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,SAVE :: npas, nexca
+      logical rnpb
+      parameter(rnpb=.true.)
+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:
+ccc      LOGICAL cycle_diurne
+ccc      PARAMETER (cycle_diurne=.FALSE.)
+c======================================================================
+c Modele thermique du sol, a activer pour le cycle diurne:
+ccc      LOGICAL soil_model
+ccc      PARAMETER (soil_model=.FALSE.)
+      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
+c le calcul du rayonnement est celle apres la precipitation des nuages.
+c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
+c la condensation et la precipitation. Cette cle augmente les impacts
+c radiatifs des nuages.
+ccc      LOGICAL new_oliq
+ccc      PARAMETER (new_oliq=.FALSE.)
+c======================================================================
+c Clefs controlant deux parametrisations de l'orographie:
+cc      LOGICAL ok_orodr
+ccc      PARAMETER (ok_orodr=.FALSE.)
+ccc      LOGICAL ok_orolf
+ccc      PARAMETER (ok_orolf=.FALSE.)
+c======================================================================
+      LOGICAL ok_journe ! sortir le fichier journalier
+      save ok_journe
+c      PARAMETER (ok_journe=.true.)
+c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      save ok_mensuel
+c      PARAMETER (ok_mensuel=.true.)
+c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      save ok_instan
+c      PARAMETER (ok_instan=.true.)
+c
+      LOGICAL ok_region ! sortir le fichier regional
+      PARAMETER (ok_region=.FALSE.)
+c======================================================================
+c
+      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
+      PARAMETER (ivap=1)
+      INTEGER iliq          ! indice de traceurs pour eau liquide
+      PARAMETER (iliq=2)
+
+      INTEGER nvm           ! nombre de vegetations
+      PARAMETER (nvm=8)
+      REAL veget(klon,nvm)  ! couverture vegetale
+      SAVE veget
+
+c
+c
+c Variables argument:
+c
+      INTEGER nlon
+      INTEGER nlev
+      INTEGER nqmax
+      REAL rjourvrai, rjour_ecri
+      REAL gmtime
+      REAL pdtphys
+      LOGICAL debut, lafin
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      REAL pphis(klon)
+      REAL paire(klon)
+      REAL presnivs(klev)
+      REAL znivsig(klev)
+      REAL zsurf(nbsrf)
+      real cufi(klon), cvfi(klon)
+
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL t(klon,klev)
+      REAL qx(klon,klev,nqmax)
+
+      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_q_dyn(klon,klev)
+
+      REAL omega(klon,klev)
+
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+      REAL d_t(klon,klev)
+      REAL d_qx(klon,klev,nqmax)
+      REAL d_ps(klon)
+
+cccIM
+      INTEGER klevp1
+      PARAMETER(klevp1=klev+1)
+#include "raddim.h"
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+
+cccIM cf. FH
+      real u850(klon),v850(klon),u200(klon),v200(klon)
+      real u500(klon),v500(klon),phi500(klon)
+
+      logical ok_hf
+      real ecrit_hf
+      integer nid_hf
+      save ok_hf, ecrit_hf, nid_hf        
+
+c  QUESTION : noms de variables ?
+
+#define histhf
+#ifdef histhf
+      data ok_hf,ecrit_hf/.true.,0.25/
+#else
+      data ok_hf/.false./
+#endif
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles      )
+c
+c Variables quasi-arguments
+c
+      REAL xjour
+      SAVE xjour
+c
+c
+c Variables propres a la physique
+c
+      REAL dtime
+      SAVE dtime                  ! pas temporel de la physique
+c
+      INTEGER radpas
+      SAVE radpas                 ! frequence d'appel rayonnement
+c
+      REAL radsol(klon)
+      SAVE radsol                 ! bilan radiatif au sol
+c
+      REAL rlat(klon)
+      SAVE rlat                   ! latitude pour chaque point
+c
+      REAL rlon(klon)
+      SAVE rlon                   ! longitude pour chaque point
+c
+cc      INTEGER iflag_con
+cc      SAVE iflag_con              ! indicateur de la convection
+c
+      INTEGER itap
+      SAVE itap                   ! compteur pour la physique
+c
+      REAL co2_ppm
+      SAVE co2_ppm                ! concentration du CO2
+c
+      REAL solaire
+      SAVE solaire                ! constante solaire
+c
+      REAL ftsol(klon,nbsrf)
+      SAVE ftsol                  ! temperature du sol
+c
+      REAL ftsoil(klon,nsoilmx,nbsrf)
+      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
+c
+      REAL fqsol(klon,nbsrf)
+      SAVE fqsol                  ! humidite du sol
+c
+      REAL fsnow(klon,nbsrf)
+      SAVE fsnow                  ! epaisseur neigeuse
+c
+      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):
+c
+      REAL zmea(klon)
+      SAVE zmea                   ! orographie moyenne
+c
+      REAL zstd(klon)
+      SAVE zstd                   ! deviation standard de l'OESM
+c
+      REAL zsig(klon)
+      SAVE zsig                   ! pente de l'OESM
+c
+      REAL zgam(klon)
+      save zgam                   ! anisotropie de l'OESM
+c
+      REAL zthe(klon)
+      SAVE zthe                   ! orientation de l'OESM
+c
+      REAL zpic(klon)
+      SAVE zpic                   ! Maximum de l'OESM
+c
+      REAL zval(klon)
+      SAVE zval                   ! Minimum de l'OESM
+c
+      REAL rugoro(klon)
+      SAVE rugoro                 ! longueur de rugosite de l'OESM
+c
+      REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
+c
+      REAL zuthe(klon),zvthe(klon)
+      SAVE zuthe
+      SAVE zvthe
+      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 qcondc(klon,klev)    ! in-cld water content from convect
+      SAVE qcondc 
+      REAL ema_work1(klon, klev), ema_work2(klon, klev)
+      SAVE ema_work1, ema_work2
+      REAL wdn(klon), tdn(klon), qdn(klon)
+
+      REAL wd(klon) ! sb
+      SAVE wd       ! sb
+
+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:
+c
+      REAL cdragh(klon) ! drag coefficient pour T and Q
+      REAL cdragm(klon) ! drag coefficient pour vent
+cAA
+cAA  Pour phytrac 
+cAA
+      REAL ycoefh(klon,klev)    ! coef d'echange pour phytrac
+      REAL yu1(klon)            ! vents dans la premiere couche U
+      REAL yv1(klon)            ! vents dans la premiere couche V
+      LOGICAL offline           ! Controle du stockage ds "physique"
+      PARAMETER (offline=.false.)
+      INTEGER physid
+      REAL pfrac_impa(klon,klev)! Produits des coefs lessivage impaction
+      save pfrac_impa
+      REAL pfrac_nucl(klon,klev)! Produits des coefs lessivage nucleation
+      save pfrac_nucl
+      REAL pfrac_1nucl(klon,klev)! Produits des coefs lessi nucl (alpha = 1)
+      save pfrac_1nucl
+      REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
+      REAL frac_nucl(klon,klev) ! idem (nucleation)
+cAA
+      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) 
+      save fder
+      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
+      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
+      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
+      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
+c
+      REAL frugs(klon,nbsrf) ! longueur de rugosite
+      save frugs
+      REAL zxrugs(klon) ! longueur de rugosite
+c
+c Conditions aux limites
+c
+      INTEGER julien
+c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+      REAL pctsrf(klon,nbsrf)
+      SAVE pctsrf                 ! sous-fraction du sol
+      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
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+      EXTERNAL angle     ! calculer angle zenithal du soleil
+      EXTERNAL alboc     ! calculer l'albedo sur ocean
+      EXTERNAL albsno    ! calculer albedo sur neige
+      EXTERNAL ajsec     ! ajustement sec
+      EXTERNAL clmain    ! couche limite 
+      EXTERNAL condsurf  ! lire les conditions aux limites
+      EXTERNAL conlmd    ! convection (schema LMD)
+cKE43
+      EXTERNAL conema3  ! convect4.3
+      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
+cAA 
+      EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
+c                          ! stockage des coefficients necessaires au
+c                          ! lessivage OFF-LINE et ON-LINE
+cAA
+      EXTERNAL hgardfou  ! verifier les temperatures
+      EXTERNAL nuage     ! calculer les proprietes radiatives
+      EXTERNAL o3cm      ! initialiser l'ozone
+      EXTERNAL orbite    ! calculer l'orbite terrestre
+      EXTERNAL ozonecm   ! prescrire l'ozone
+      EXTERNAL phyetat0  ! lire l'etat initial de la physique
+      EXTERNAL phyredem  ! ecrire l'etat de redemarrage de la physique
+      EXTERNAL radlwsw   ! rayonnements solaire et infrarouge
+      EXTERNAL suphec    ! initialiser certaines constantes
+      EXTERNAL transp    ! transport total de l'eau et de l'energie
+      EXTERNAL ecribina  ! ecrire le fichier binaire global
+      EXTERNAL ecribins  ! ecrire le fichier binaire global
+      EXTERNAL ecrirega  ! ecrire le fichier binaire regional
+      EXTERNAL ecriregs  ! ecrire le fichier binaire regional
+c
+c Variables locales
+c
+      real clwcon(klon,klev),rnebcon(klon,klev)
+      real clwcon0(klon,klev),rnebcon0(klon,klev)
+      save rnebcon, clwcon
+
+      REAL rhcl(klon,klev)    ! humiditi relative ciel clair
+      REAL dialiq(klon,klev)  ! eau liquide nuageuse
+      REAL diafra(klon,klev)  ! fraction nuageuse
+      REAL cldliq(klon,klev)  ! eau liquide nuageuse
+      REAL cldfra(klon,klev)  ! fraction nuageuse
+      REAL cldtau(klon,klev)  ! epaisseur optique
+      REAL cldemi(klon,klev)  ! emissivite infrarouge
+c
+CXXX 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)
+CXXX
+      REAL heat(klon,klev)    ! chauffage solaire
+      REAL heat0(klon,klev)   ! chauffage solaire ciel clair
+      REAL cool(klon,klev)    ! refroidissement infrarouge
+      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,sollwdown
+      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+cccIM
+      SAVE  ZFSUP,ZFSDN,ZFSUP0,ZFSDN0 
+
+      INTEGER itaprad
+      SAVE itaprad
+c
+      REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
+      REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
+c
+      REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
+      REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
+c
+      REAL zxtsol(klon), zxqsol(klon), zxsnow(klon), zxfluxlat(klon)
+c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+c
+      CHARACTER*2 str2
+      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
+      real zqsat(klon,klev)
+      INTEGER i, k, iq, ig, j, nsrf, ll
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+      REAL zphi(klon,klev)
+      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
+c
+c con: convection
+c lsc: condensation a grande echelle (Large-Scale-Condensation)
+c ajs: ajustement sec
+c eva: evaporation de l'eau liquide nuageuse
+c vdf: couche limite (Vertical DiFfusion)
+      REAL d_t_con(klon,klev),d_q_con(klon,klev)
+      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)
+      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)
+c
+      REAL pmfu(klon,klev), pmfd(klon,klev)
+      REAL pen_u(klon,klev), pen_d(klon,klev)
+      REAL pde_u(klon,klev), pde_d(klon,klev)
+      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)
+      REAL rain_con(klon), rain_lsc(klon)
+      REAL snow_con(klon), snow_lsc(klon)
+      REAL d_ts(klon,nbsrf)
+c
+      REAL d_u_vdf(klon,klev), d_v_vdf(klon,klev)
+      REAL d_t_vdf(klon,klev), d_q_vdf(klon,klev)
+c
+      REAL d_u_oro(klon,klev), d_v_oro(klon,klev)
+      REAL d_t_oro(klon,klev)
+      REAL d_u_lif(klon,klev), d_v_lif(klon,klev)
+      REAL d_t_lif(klon,klev)
+
+      REAL ratqs(klon,klev),ratqss(klon,klev),ratqsc(klon,klev)
+      real ratqsbas,ratqshaut
+      save ratqsbas,ratqshaut, ratqs
+      real zpt_conv(klon,klev)
+
+c Parametres lies au nouveau schema de nuages (SB, PDF)
+      real fact_cldcon
+      real facttemps
+      logical ok_newmicro
+      save ok_newmicro
+      save fact_cldcon,facttemps
+      real facteur
+
+      integer iflag_cldcon
+      save iflag_cldcon
+
+      logical ptconv(klon,klev)
+
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+      INTEGER ecrit_mth
+      SAVE ecrit_mth   ! frequence d'ecriture (fichier mensuel)
+c
+      INTEGER ecrit_day
+      SAVE ecrit_day   ! frequence d'ecriture (fichier journalier)
+c
+      INTEGER ecrit_ins
+      SAVE ecrit_ins   ! frequence d'ecriture (fichier instantane)
+c
+      INTEGER ecrit_reg
+      SAVE ecrit_reg   ! frequence d'ecriture
+c
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+c
+c
+c Variables locales pour effectuer les appels en serie
+c
+      REAL t_seri(klon,klev), q_seri(klon,klev)
+      REAL ql_seri(klon,klev),qs_seri(klon,klev)
+      REAL u_seri(klon,klev), v_seri(klon,klev)
+c
+      REAL tr_seri(klon,klev,nbtr)
+      REAL d_tr(klon,klev,nbtr)
+
+      REAL zx_rh(klon,klev)
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+c
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
+      REAL zx_tmp_fi2d(klon)
+      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
+      SAVE nid_day, nid_mth, nid_ins
+c
+      INTEGER nhori, nvert
+      REAL zsto, zout
+      real zjulian
+      save zjulian
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+      real date0
+      integer idayref
+
+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     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/2/
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+c-jld ec_conser
+cIM
+      REAL t2m(klon,nbsrf), q2m(klon,nbsrf)
+      REAL u10m(klon,nbsrf), v10m(klon,nbsrf)
+      REAL zt2m(klon), zq2m(klon)
+      REAL zu10m(klon), zv10m(klon)
+      CHARACTER*40 t2mincels, t2maxcels 
+c
+c Declaration des constantes et des fonctions thermodynamiques
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c======================================================================
+      modname = 'physiq'
+      IF (if_ebil.ge.1) THEN
+        DO i=1,klon
+          zero_v(i)=0.
+        END DO 
+      END IF 
+      ok_sync=.TRUE.
+      IF (nqmax .LT. 2) THEN
+         PRINT*, 'eaux vapeur et liquide sont indispensables'
+         CALL ABORT
+      ENDIF
+      IF (debut) THEN
+         CALL suphec ! initialiser constantes et parametres phys.
+      ENDIF
+
+
+c======================================================================
+      xjour = rjourvrai
+c
+c Si c'est le debut, il faut initialiser plusieurs choses
+c          ********
+c
+       IF (debut) THEN
+C
+         IF (if_ebil.ge.1) d_h_vcol_phy=0.
+c
+c appel a la lecture du run.def physique
+c
+         call conf_phys(ocean, ok_veget, ok_journe, ok_mensuel,
+     .                  ok_instan, fact_cldcon, facttemps,ok_newmicro,
+     .                  iflag_cldcon,ratqsbas,ratqshaut, if_ebil)
+
+         DO k = 2, nvm          ! pas de vegetation
+            DO i = 1, klon
+               veget(i,k) = 0.0
+            ENDDO
+         ENDDO
+         DO i = 1, klon
+            veget(i,1) = 1.0    ! il n'y a que du desert
+         ENDDO
+         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,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, rnebcon, ratqs,clwcon )
+
+c
+         radpas = NINT( 86400./dtime/nbapp_rad)
+
+c
+         CALL printflag( tabcntr0,radpas,ok_ocean,ok_oasis ,ok_journe,
+     ,                    ok_instan, ok_region )
+c
+         IF (ABS(dtime-pdtphys).GT.0.001) THEN
+            PRINT*, 'Pas physique n est pas correcte',dtime,pdtphys
+            abort_message=' See above '
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlon .NE. klon) THEN
+            PRINT*, 'nlon et klon ne sont pas coherents', nlon, klon
+            abort_message=' See above '
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlev .NE. klev) THEN
+            PRINT*, 'nlev et klev ne sont pas coherents', nlev, klev
+            abort_message=' See above '
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+c
+         IF (dtime*FLOAT(radpas).GT.21600..AND.cycle_diurne) THEN 
+           PRINT*, 'Nbre d appels au rayonnement insuffisant'
+           PRINT*, "Au minimum 4 appels par jour si cycle diurne"
+           abort_message=' See above '
+           call abort_gcm(modname,abort_message,1)
+         ENDIF
+         PRINT*, "Clef pour la convection, iflag_con=", iflag_con
+         PRINT*, "Clef pour le driver de la convection, ok_cvl=", ok_cvl
+c
+cKE43
+c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.GE.3) 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
+         rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+         ENDDO
+         CALL SUGWD(klon,klev,paprs,pplay)
+         DO i=1,klon
+         zuthe(i)=0.
+         zvthe(i)=0.
+         if(zstd(i).gt.10.)then
+           zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+           zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+         endif
+         ENDDO
+         ENDIF
+c
+c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         PRINT*,'La frequence de lecture surface est de ', lmt_pas
+c
+         ecrit_mth = NINT(86400./dtime *ecritphy)  ! tous les ecritphy jours
+         IF (ok_mensuel) THEN
+         PRINT*, 'La frequence de sortie mensuelle est de ', ecrit_mth
+         ENDIF
+         ecrit_day = NINT(86400./dtime *1.0)  ! tous les jours
+         IF (ok_journe) THEN
+         PRINT*, 'La frequence de sortie journaliere est de ',ecrit_day
+         ENDIF
+ccc         ecrit_ins = NINT(86400./dtime *0.5)  ! 2 fois par jour
+ccc         ecrit_ins = NINT(86400./dtime *0.25)  ! 4 fois par jour
+         ecrit_ins = NINT(86400./dtime/48.)  ! a chaque pas de temps ==> PB. dans time_counter pour 1mois
+         ecrit_ins = NINT(86400./dtime/12.)  ! toutes les deux heures
+         IF (ok_instan) THEN
+         PRINT*, 'La frequence de sortie instant. est de ', ecrit_ins
+         ENDIF
+         ecrit_reg = NINT(86400./dtime *0.25)  ! 4 fois par jour
+         IF (ok_region) THEN
+         PRINT*, 'La frequence de sortie region est de ', ecrit_reg
+         ENDIF
+
+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
+cccIM
+      t2mincels = 't_min(X)'
+      t2maxcels = 't_max(X)'
+
+cccIM cf. FH
+c
+c=============================================================
+c   Initialisation des sorties
+c=============================================================
+#ifdef histhf
+#include "ini_histhf.h"
+#endif
+
+#include "ini_histday.h"
+#include "ini_histmth.h"
+#include "ini_histins.h"
+
+cXXXPB Positionner date0 pour initialisation de ORCHIDEE
+      date0 = zjulian
+C      date0 = day_ini
+      WRITE(*,*) 'physiq date0 : ',date0
+c
+c
+c
+c Prescrire l'ozone dans l'atmosphere
+c
+c
+cc         DO i = 1, klon
+cc         DO k = 1, klev
+cc            CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
+cc         ENDDO
+cc         ENDDO
+c
+c
+      ENDIF
+c
+c   ****************     Fin  de   IF ( debut  )   ***************
+c
+c
+c Mettre a zero des variables de sortie (pour securite)
+c
+      DO i = 1, klon
+         d_ps(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO iq = 1, nqmax
+      DO k = 1, klev
+      DO i = 1, klon
+         d_qx(i,k,iq) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c Ne pas affecter les valeurs entrees de u, v, h, et q
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k)  = t(i,k)
+         u_seri(i,k)  = u(i,k)
+         v_seri(i,k)  = v(i,k)
+         q_seri(i,k)  = qx(i,k,ivap)
+         ql_seri(i,k) = qx(i,k,iliq)
+         qs_seri(i,k) = 0.
+      ENDDO
+      ENDDO
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         tr_seri(i,k,iq-2) = qx(i,k,iq)
+      ENDDO
+      ENDDO
+      ENDDO
+      ELSE
+      DO k = 1, klev
+      DO i = 1, klon
+         tr_seri(i,k,1) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+C
+      IF (if_ebil.ge.1) THEN 
+        DO i = 1, klon
+          ztsol(i) = 0.
+        ENDDO
+        DO nsrf = 1, nbsrf
+          DO i = 1, klon
+            ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+          ENDDO
+        ENDDO
+        ztit='after dynamic'
+        CALL diagetpq(paire,ztit,ip_ebil,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(paire,ztit,ip_ebil
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol+d_h_vcol_phy, d_qt, 0.
+     s      , fs_bound, fq_bound )
+      END IF 
+
+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
+      DO k = 1, klev
+      DO i = 1, klon
+         zphi(i,k) = pphi(i,k) + pphis(i)
+      ENDDO
+      ENDDO
+c
+c Verifier les temperatures
+c
+      CALL hgardfou(t_seri,ftsol,'debutphy')
+c
+c Incrementer le compteur de la physique
+c
+      itap   = itap + 1
+      julien = MOD(NINT(xjour),360)
+c
+c Mettre en action les conditions aux limites (albedo, sst, etc.).
+c Prescrire l'ozone et calculer l'albedo sur l'ocean.
+c
+      IF (MOD(itap-1,lmt_pas) .EQ. 0) THEN
+         PRINT *,' PHYS cond  julien ',julien
+         CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
+      ENDIF
+c
+c Re-evaporer l'eau liquide nuageuse
+c
+      DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+c        zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+         zb = MAX(0.0,ql_seri(i,k))
+         za = - MAX(0.0,ql_seri(i,k))
+     .                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         t_seri(i,k) = t_seri(i,k) + za
+         q_seri(i,k) = q_seri(i,k) + zb
+         ql_seri(i,k) = 0.0
+         d_t_eva(i,k) = za
+         d_q_eva(i,k) = zb
+      ENDDO
+      ENDDO
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after reevap'
+        CALL diagetpq(paire,ztit,ip_ebil,2,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(paire,ztit,ip_ebil
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      END IF 
+C
+c
+c Appeler la diffusion verticale (programme de couche limite)
+c
+      DO i = 1, klon
+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
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         frugs(i,nsrf) = MAX(frugs(i,nsrf),0.001)
+cccc        frugs(i,nsrf) = MAX(frugs(i,nsrf),0.000015)
+      ENDDO
+      ENDDO
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+            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,date0,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,
+     s            dsens, devap,
+     s            ycoefh,yu1,yv1, t2m, q2m, u10m, v10m) 
+c
+CXXX PB
+CXXX Incrementation des flux
+CXXX
+      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
+         t_seri(i,k) = t_seri(i,k) + d_t_vdf(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_vdf(i,k)
+         u_seri(i,k) = u_seri(i,k) + d_u_vdf(i,k)
+         v_seri(i,k) = v_seri(i,k) + d_v_vdf(i,k)
+      ENDDO
+      ENDDO
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after clmain'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(paire,ztit,ip_ebil
+     e      , zero_v, zero_v, zero_v, zero_v, sens
+     e      , evap  , zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+C
+c
+c Incrementer la temperature du sol
+c
+      DO i = 1, klon
+         zxtsol(i) = 0.0
+         zxfluxlat(i) = 0.0
+cccIM
+         zt2m(i) = 0.0
+         zq2m(i) = 0.0
+         zu10m(i) = 0.0
+         zv10m(i) = 0.0
+c
+         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
+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)
+            zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf)*pctsrf(i,nsrf)
+cccIM
+            zt2m(i) = zt2m(i) + t2m(i,nsrf)*pctsrf(i,nsrf)
+            zq2m(i) = zq2m(i) + q2m(i,nsrf)*pctsrf(i,nsrf)
+            zu10m(i) = zu10m(i) + u10m(i,nsrf)*pctsrf(i,nsrf)
+            zv10m(i) = zv10m(i) + v10m(i,nsrf)*pctsrf(i,nsrf)
+c        ENDIF 
+        ENDDO
+      ENDDO
+
+c
+c Si une sous-fraction n'existe pas, elle prend la temp. moyenne
+c
+      DO nsrf = 1, nbsrf
+        DO i = 1, klon
+          IF (pctsrf(i,nsrf) .LT. epsfra) ftsol(i,nsrf) = zxtsol(i)
+cccIM
+          IF (pctsrf(i,nsrf) .LT. epsfra) t2m(i,nsrf) = zt2m(i)
+          IF (pctsrf(i,nsrf) .LT. epsfra) q2m(i,nsrf) = zq2m(i)
+          IF (pctsrf(i,nsrf) .LT. epsfra) u10m(i,nsrf) = zu10m(i)
+          IF (pctsrf(i,nsrf) .LT. epsfra) v10m(i,nsrf) = zv10m(i)
+        ENDDO
+      ENDDO
+c
+c
+c Calculer la derive du flux infrarouge
+c
+cXXX      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+cXXX        IF (pctsrf(i,nsrf) .GE. EPSFRA) THEN 
+            dlw(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+cXXX     .          *(ftsol(i,nsrf)-zxtsol(i))
+cXXX     .          *pctsrf(i,nsrf)
+cXXX        ENDIF 
+cXXX      ENDDO
+      ENDDO
+c
+c Appeler la convection (au choix)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_q_dyn(i,k) 
+     .               + d_q_vdf(i,k)/dtime
+         conv_t(i,k) = d_t_dyn(i,k) 
+     .               + d_t_vdf(i,k)/dtime
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         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
+          stop'reactiver le call conlmd dans physiq.F'
+c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
+c    .             d_t_con, d_q_con,
+c    .             rain_con, snow_con, ibas_con, itop_con)
+      ELSE IF (iflag_con.EQ.2) THEN
+      CALL conflx(dtime, paprs, pplay, t_seri, q_seri,
+     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)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.GE.3) THEN
+c nb of tracers for the KE convection:
+          if (nqmax .GE. 4) then
+              ntra = nbtr
+          else
+              ntra = 1 
+          endif
+c
+c sb, oct02:
+c Schema de convection modularise et vectorise:
+c (driver commun aux versions 3 et 4)
+c
+          IF (ok_cvl) THEN ! new driver for convectL
+
+          CALL concvl (iflag_con,
+     .        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,
+     .        Ma,cape,tvp,iflagctrl,
+     .        pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd)
+
+          ELSE ! ok_cvl
+
+          if (iflag_con.eq.4) 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)
+
+            qcondc=0.0
+
+          else
+
+c          print*,'Avant conema OUI'
+          CALL conema3 (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,bas,top,
+     .        Ma,cape,tvp,rflag,
+     .        pbase
+     .        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr
+     .        ,clwcon0)
+          print*,'Apres conema3 '
+
+           IF (.NOT. ok_gust) THEN
+           do i = 1, klon
+            wd(i)=0.0
+           enddo
+           ENDIF
+
+c Calculer l'humidite relative pour diagnostique
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+c   calcul des proprietes des nuages convectifs
+             clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
+             call clouds_gno
+     s       (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
+
+          endif
+
+          ENDIF ! ok_cvl
+
+          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
+      ENDIF
+
+c     CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+c    .              d_u_con, d_v_con)
+      DO k = 1, klev
+        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
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after convect'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(paire,ztit,ip_ebil
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_con, snow_con, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+C
+      IF (check) THEN
+          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 .AND. debut) THEN 
+              PRINT*, 'Pour l instant, seul conflx fonctionne ',
+     $            'avec traceurs', iflag_con
+              PRINT*,' Mettre iflag_con', 
+     $            ' = 2 dans run.def et repasser'
+c              CALL abort
+              ENDIF 
+c
+      ENDIF !--nqmax.GT.2
+c
+c Appeler l'ajustement sec
+c
+      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
+      IF (if_ebil.ge.2) THEN 
+        ztit='after dry_adjust'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+
+
+c-------------------------------------------------------------------------
+c  Caclul des ratqs
+c-------------------------------------------------------------------------
+
+c      print*,'calcul des ratqs'
+c   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+c   ----------------
+c   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cldcon.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas
+     s        +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+      endif
+
+c   ratqs stables
+c   -------------
+      do k=1,klev
+         ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas)*
+     s   min((paprs(:,1)-pplay(:,k))/(paprs(:,1)-30000.),1.)        
+      enddo
+
+
+c  ratqs final
+c  -----------
+      if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2) then
+c   les ratqs sont une conbinaison de ratqss et ratqsc
+c   ratqs final
+c   1e4 (en gros 3 heures), en dur pour le moment, est le temps de
+c   relaxation des ratqs
+c         facttemps=exp(-pdtphys/1.e4)
+         facteur=exp(-pdtphys*facttemps)
+         ratqs(:,:)=max(ratqs(:,:)*facteur,ratqss(:,:))
+         ratqs(:,:)=max(ratqs(:,:),ratqsc(:,:))
+c         print*,'calcul des ratqs fini'
+      else
+c   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      endif
+
+
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c-------------------------------------------------------------------------
+      CALL fisrtilp(dtime,paprs,pplay,
+     .           t_seri, q_seri,ptconv,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,
+     .           prfl, psfl, rhcl)
+
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k) + d_t_lsc(i,k)
+         q_seri(i,k) = q_seri(i,k) + d_q_lsc(i,k)
+         ql_seri(i,k) = ql_seri(i,k) + d_ql_lsc(i,k)
+         cldfra(i,k) = rneb(i,k)
+         IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,paire)
+         PRINT*, "apresilp=", za
+         zx_t = 0.0
+         za = 0.0
+         DO i = 1, klon
+            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
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after fisrt'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(paire,ztit,ip_ebil
+     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+     e      , zero_v, rain_lsc, snow_lsc, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+c
+c-------------------------------------------------------------------
+c  PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
+c-------------------------------------------------------------------
+
+c 1. NUAGES CONVECTIFS
+c
+      IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
+
+c Nuages diagnostiques pour Tiedtke
+      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
+
+      ELSE IF (iflag_cldcon.eq.3) THEN
+c  On prend pour les nuages convectifs le max du calcul de la
+c  convection et du calcul du pas de temps précédent diminué d'un facteur
+c  facttemps
+c      facttemps=pdtphys/1.e4
+      facteur = pdtphys *facttemps
+      do k=1,klev
+         do i=1,klon
+            rnebcon(i,k)=rnebcon(i,k)*facteur
+            if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k))
+     s      then
+                rnebcon(i,k)=rnebcon0(i,k)
+                clwcon(i,k)=clwcon0(i,k)
+            endif
+         enddo
+      enddo
+
+c   On prend la somme des fractions nuageuses et des contenus en eau
+      cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+      cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
+
+
+      ENDIF
+c
+c 2. NUAGES STARTIFORMES
+c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, 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 Precipitation totale
+c
+      DO i = 1, klon
+         rain_fall(i) = rain_con(i) + rain_lsc(i)
+         snow_fall(i) = snow_con(i) + snow_lsc(i)
+      ENDDO
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit="after diagcld"
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c Calculer l'humidite relative pour diagnostique
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zx_rh(i,k) = q_seri(i,k)/zx_qs
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+c
+c Calculer les parametres optiques des nuages et quelques
+c parametres pour diagnostiques:
+c
+      if (ok_newmicro) then
+      CALL newmicro (paprs, pplay,ok_newmicro,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq)
+      else
+      CALL nuage (paprs, pplay,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq)
+      endif
+c
+c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+      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, 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,
+cccIMs             topsw0,toplw0,solsw0,sollw0)
+     s             topsw0,toplw0,solsw0,sollw0,
+     s             ZFSUP,ZFSDN,ZFSUP0,ZFSDN0)
+      itaprad = 0
+      ENDIF
+      itaprad = itaprad + 1
+c
+c Ajouter la tendance des rayonnements (tous les pas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k)
+     .               + (heat(i,k)-cool(i,k)) * dtime/86400.
+      ENDDO
+      ENDDO
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after rad'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(paire,ztit,ip_ebil
+     e      , topsw, toplw, solsw, sollw, zero_v
+     e      , zero_v, zero_v, zero_v, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+      END IF 
+c
+c
+c Calculer l'hydrologie de la surface
+c
+c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+c     .            agesno, ftsol,fqsol,fsnow, ruis)
+c
+      DO i = 1, klon
+         zxqsol(i) = 0.0
+         zxsnow(i) = 0.0
+      ENDDO
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         zxqsol(i) = zxqsol(i) + fqsol(i,nsrf)*pctsrf(i,nsrf)
+         zxsnow(i) = zxsnow(i) + fsnow(i,nsrf)*pctsrf(i,nsrf)
+      ENDDO
+      ENDDO
+c
+c Si une sous-fraction n'existe pas, elle prend la valeur moyenne
+c
+cXXX      DO nsrf = 1, nbsrf
+cXXX      DO i = 1, klon
+cXXX         IF (pctsrf(i,nsrf).LT.epsfra) THEN
+cXXX            fqsol(i,nsrf) = zxqsol(i)
+cXXX            fsnow(i,nsrf) = zxsnow(i)
+cXXX         ENDIF
+cXXX      ENDDO
+cXXX      ENDDO
+c
+c Calculer le bilan du sol et la derive de temperature (couplage)
+c
+      DO i = 1, klon
+c         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+c a la demande de JLD
+         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
+      ENDDO
+c
+cmoddeblott(jan95)
+c Appeler le programme de parametrisation de l'orographie
+c a l'echelle sous-maille:
+c
+      IF (ok_orodr) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+c        IF ((zstd(i).gt.10.0)) THEN
+        IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,idx,itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustr, zvstr,
+     s                   d_t_oro, d_u_oro, d_v_oro)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_oro(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_oro(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_oro(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orodr
+c
+      IF (ok_orolf) THEN
+c
+c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+        IF ((zpic(i)-zmea(i)).GT.100.) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+c        igwdim=MAX(1,igwd)
+c
+        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd,zpic,
+     e                   itest,
+     e                   t_seri, u_seri, v_seri,
+     s                   zulow, zvlow, zustr, zvstr,
+     s                   d_t_lif, d_u_lif, d_v_lif)
+c
+c  ajout des tendances
+        DO k = 1, klev
+        DO i = 1, klon
+           t_seri(i,k) = t_seri(i,k) + d_t_lif(i,k)
+           u_seri(i,k) = u_seri(i,k) + d_u_lif(i,k)
+           v_seri(i,k) = v_seri(i,k) + d_v_lif(i,k)
+        ENDDO
+        ENDDO
+c
+      ENDIF ! fin de test sur ok_orolf
+c
+      IF (if_ebil.ge.2) THEN 
+        ztit='after orography'
+        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+      END IF 
+c
+c
+cAA
+cAA Installation de l'interface online-offline pour traceurs
+cAA
+c====================================================================
+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.GE.3) THEN
+c           on ajoute les tendances calculees par KE43
+cXXX OM on onhibe la convection sur les traceurs
+        DO iq=1, nqmax-2 ! Sandrine a -3 ???
+cXXX OM on inhibe la convection sur les traceur
+cXXX        DO k = 1, nlev
+cXXX        DO i = 1, klon
+cXXX          tr_seri(i,k,iq) = tr_seri(i,k,iq) + d_tr(i,k,iq)
+cXXX        ENDDO
+cXXX        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,lafin,
+     I                   nqmax-2,
+     I                   nlon,nlev,dtime,
+     I                   t,paprs,pplay,
+     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   ycoefh,yu1,yv1,ftsol,pctsrf,rlat,
+     I                   frac_impa, frac_nucl,
+     I                   rlon,presnivs,paire,pphis,
+     O                   tr_seri)
+      ENDIF 
+
+      IF (offline) THEN
+
+	 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                   pphis,paire,dtime,itap)
+
+
+      ENDIF
+
+c
+c Calculer le transport de l'eau et de l'energie (diagnostique)
+c
+      CALL transp (paprs,zxtsol,
+     e                   t_seri, q_seri, u_seri, v_seri, zphi,
+     s                   ve, vq, ue, uq)
+c
+c Accumuler les variables a stocker dans les fichiers histoire:
+c
+c
+c
+c+jld ec_conser
+      DO k = 1, klev
+      DO i = 1, klon
+        ZRCPD = RCPD*(1.0+RVTMP2*q_seri(i,k))
+        d_t_ec(i,k)=0.5/ZRCPD
+     $      *(u(i,k)**2+v(i,k)**2-u_seri(i,k)**2-v_seri(i,k)**2)
+        t_seri(i,k)=t_seri(i,k)+d_t_ec(i,k)
+        d_t_ec(i,k) = d_t_ec(i,k)/dtime
+       END DO 
+      END DO 
+c-jld ec_conser
+      IF (if_ebil.ge.1) THEN 
+        ztit='after physic'
+        CALL diagetpq(paire,ztit,ip_ebil,1,1,dtime
+     e      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay
+     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C     Comme les tendances de la physique sont ajoute dans la dynamique,
+C     on devrait avoir que la variation d'entalpie par la dynamique
+C     est egale a la variation de la physique au pas de temps precedent.
+C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(paire,ztit,ip_ebil
+     e      , topsw, toplw, solsw, sollw, sens
+     e      , evap, rain_fall, snow_fall, ztsol
+     e      , d_h_vcol, d_qt, d_ec
+     s      , fs_bound, fq_bound )
+C
+      d_h_vcol_phy=d_h_vcol
+C
+      END IF 
+C
+cccIM cf. FH
+c=======================================================================
+c   SORTIES
+c=======================================================================
+
+c   Interpollation sur quelques niveaux de pression
+c   -----------------------------------------------
+
+      call plevel(klon,klev,.true. ,pplay,85000.,u_seri,u850)
+      call plevel(klon,klev,.false.,pplay,85000.,v_seri,v850)
+      call plevel(klon,klev,.true. ,pplay,50000.,u_seri,u500)
+      call plevel(klon,klev,.false.,pplay,50000.,v_seri,v500)
+      call plevel(klon,klev,.true. ,pplay,20000.,u_seri,u200)
+      call plevel(klon,klev,.false.,pplay,20000.,v_seri,v200)
+      call plevel(klon,klev,.true. ,pplay,50000.,zphi,phi500)
+
+c=============================================================
+c   Ecriture des sorties
+c=============================================================
+
+#ifdef histhf
+#include "write_histhf.h"
+#endif
+
+#include "write_histday.h"
+#include "write_histmth.h"
+#include "write_histins.h"
+
+c=============================================================
+c
+c Convertir les incrementations en tendances
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
+         d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
+         d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
+         d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
+         d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
+      ENDDO
+      ENDDO
+c
+      IF (nqmax.GE.3) THEN
+      DO iq = 3, nqmax
+      DO  k = 1, klev
+      DO  i = 1, klon
+         d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
+      ENDDO
+      ENDDO
+      ENDDO
+      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
+c====================================================================
+c
+      IF (lafin) THEN
+         itau_phy = itau_phy + itap
+ccc         IF (ok_oasis) CALL quitcpl
+         CALL phyredem ("restartphy.nc",dtime,radpas,co2_ppm,solaire,
+     .      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, rnebcon, ratqs, clwcon)
+      ENDIF
+
+      RETURN
+      END
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+      IMPLICIT none
+c
+c Calculer et imprimer l'eau totale. A utiliser pour verifier
+c la conservation de l'eau
+c
+#include "YOMCST.h"
+      INTEGER klon,klev
+      REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+      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)) * aire(i)
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+c
+      qcheck = qtotal/zx
+c
+      RETURN
+      END
+      SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+      IMPLICIT none
+c
+c Tranformer une variable de la grille physique a
+c la grille d'ecriture
+c
+      INTEGER nfield,nlon,iim,jjmp1, jjm
+      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,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
+         ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
+         ENDDO
+      ENDDO
+      RETURN
+      END
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phystokenc.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phystokenc.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phystokenc.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/phytrac.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phytrac.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/phytrac.F	(revision 428)
@@ -0,0 +1,752 @@
+c
+c $Header$
+c
+      SUBROUTINE phytrac (rnpb,
+     I                   debutphy,lafin,
+     I                   nqmax,
+     I                   nlon,nlev,pdtphys,
+     I                   t_seri,paprs,pplay,
+     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   coefh,yu1,yv1,ftsol,pctsrf,xlat,
+     I                   frac_impa, frac_nucl,
+     I                   xlon,presnivs,paire,pphis,
+     O                   tr_seri)
+      USE ioipsl
+      USE histcom
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+cAA Remarques en vrac:
+cAA--------------------
+cAA 1/ le call phytrac se fait avec nqmax-2 donc nous avons bien 
+cAA les vrais traceurs (nbtr) dans phytrac (pas la vapeur ni eau liquide)
+cAA 2/ Le choix du radon et du pb se fait juste avec un data 
+cAA    (peu propre). Peut-etre pourrait-on prevoir dans l'avenir 
+cAA    une variable "type de traceur" 
+c======================================================================
+#include "YOMCST.h"
+#include "dimensions.h"
+#include "dimphy.h"
+#include "indicesol.h"
+#include "temps.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
+      integer nqmax ! nombre de traceurs auxquels on applique la physique
+      real pdtphys  ! pas d'integration pour la physique (seconde)
+      real t_seri(nlon,nlev) ! temperature
+      real tr_seri(nlon,nlev,nbtr) ! traceur  
+      real paprs(nlon,nlev+1)  ! pression pour chaque inter-couche (en Pa)
+      real pplay(nlon,nlev)  ! pression pour le mileu de chaque couche (en Pa)
+      real presnivs(klev) ! pressions approximat. des milieux couches ( en PA)
+      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
+cAA Rem : nbtr : nombre de vrais traceurs est defini dans dimphy.h
+c
+c   convection:
+c   -----------
+c
+      REAL pmfu(nlon,nlev)  ! flux de masse dans le panache montant
+      REAL pmfd(nlon,nlev)  ! flux de masse dans le panache descendant
+      REAL pen_u(nlon,nlev) ! flux entraine dans le panache montant
+      REAL pde_u(nlon,nlev) ! flux detraine dans le panache montant
+      REAL pen_d(nlon,nlev) ! flux entraine dans le panache descendant
+      REAL pde_d(nlon,nlev) ! flux detraine dans le panache descendant
+c
+c   Couche limite:
+c   --------------
+c
+      REAL coefh(nlon,nlev) ! coeff melange CL
+      REAL yu1(nlon)        ! vents au premier niveau
+      REAL yv1(nlon)        ! vents au premier niveau
+      REAL xlat(nlon)       ! latitudes pour chaque point 
+      REAL xlon(nlon)       ! longitudes pour chaque point 
+
+c
+c   Lessivage:
+c   ----------
+c
+c pour le ON-LINE
+c
+      REAL frac_impa(nlon,nlev)  ! fraction d'aerosols impactes
+      REAL frac_nucl(nlon,nlev)  ! fraction d'aerosols nuclees
+c
+cAA
+cAA Arguments necessaires pour les sources et puits de traceur:
+cAA ----------------
+cAA
+      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
+cAA ----------------------------
+cAA
+cAA Sources et puits des traceurs:
+cAA ------------------------------
+cAA
+cAA Pour l'instant seuls les cas du rn et du pb ont ete envisages.
+
+      REAL source(klon)       ! a voir lorsque le flux est prescrit 
+      REAL topuits(klev,nbtr)  ! a voir 
+cAA 
+cAA Pour la source de radon et son reservoir de sol
+cAA ................................................
+ 
+      REAL trs(klon,nbtr)    ! Conc. radon ds le sol
+      SAVE trs
+
+      REAL masktr(klon,nbtr) ! Masque reservoir de sol traceur
+c                            Masque de l'echange avec la surface
+c                           (1 = reservoir) ou (possible => 1 )
+      SAVE masktr
+      REAL fshtr(klon,nbtr)  ! Flux surfacique dans le reservoir de sol
+      SAVE fshtr
+      REAL hsoltr(nbtr)      ! Epaisseur equivalente du reservoir de sol
+      SAVE hsoltr
+      REAL tautr(nbtr)       ! Constante de decroissance radioactive
+      SAVE tautr
+      REAL vdeptr(nbtr)      ! Vitesse de depot sec dans la couche Brownienne
+      SAVE vdeptr
+      REAL scavtr(nbtr)      ! Coefficient de lessivage
+      SAVE scavtr
+cAA
+      CHARACTER*1 itn
+C maf ioipsl
+      CHARACTER*2 str2
+      INTEGER nhori, nvert
+      REAL zsto, zout, zjulian
+      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)
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+      INTEGER itra
+      SAVE itra                   ! compteur pour la physique
+C
+C Variables liees a l'ecriture de la bande histoire : phytrac.nc
+c
+      INTEGER ecrit_tra
+      SAVE ecrit_tra   
+      logical ok_sync
+      parameter (ok_sync = .true.)
+C
+C nature du traceur
+c
+      logical aerosol(nbtr)  ! Nature du traceur
+c                            ! aerosol(it) = true  => aerosol 
+c                            ! aerosol(it) = false => gaz 
+c                            ! nat_trac(it) = 1. aerosolc
+      logical clsol(nbtr)    ! clsol(it) = true => CL sol calculee
+      logical radio(nbtr)    ! radio(it)=true => decroisssance radioactive
+      save aerosol,clsol,radio
+C
+c======================================================================
+c
+c Declaration des procedures appelees
+c
+c--modif convection tiedtke
+      INTEGER i, k, it,itap
+	save itap
+      REAL delp(klon,klev)
+c--end modif
+c
+c Variables liees a l'ecriture de la bande histoire physique
+c
+c Variables locales pour effectuer les appels en serie
+c----------------------------------------------------
+c
+      REAL d_tr(klon,klev), d_trs(klon) ! tendances de traceurs 
+      REAL d_tr_cl(klon,klev) ! tendance de traceurs  couche limite
+      REAL d_tr_cv(klon,klev) ! tendance de traceurs  convection 
+      REAL d_tr_dec(klon,klev,nbtr) ! la tendance de la decroissance 
+c                                   ! radioactive du rn - > pb 
+      REAL d_tr_lessi_impa(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par impaction
+      REAL d_tr_lessi_nucl(klon,klev,nbtr) ! la tendance du lessivage 
+c                                          ! par nucleation 
+      REAL fluxrn(klon,klev) 
+      REAL fluxpb(klon,klev) 
+      REAL pbimpa(klon,klev) 
+      REAL pbnucl(klon,klev) 
+      REAL rn(klon,klev) 
+      REAL pb(klon,klev) 
+      REAL flestottr(klon,klev,nbtr) ! flux de lessivage 
+c                                    ! dans chaque couche 
+
+C
+      character*20 modname
+      character*80 abort_message
+c
+c   Controles
+c-------------
+      logical first,couchelimite,convection,lessivage,sorties,
+     s        rnpb,inirnpb
+      save first,couchelimite,convection,lessivage,sorties,
+     s     inirnpb
+      data first,couchelimite,convection,lessivage,sorties
+c$$$ OM Test KE     s     /.true.,.true.,.true.,.true.,.true./
+     s     /.true.,.true.,.false.,.true.,.true./
+c
+c======================================================================
+c         ecrit_tra = NINT(86400./pdtphys *1.0)  ! tous les jours
+         modname='phytrac'
+
+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
+           print*,'NQMAX=',nqmax
+           print*,'NBTR=',nbtr
+           abort_message='See above'
+           call abort_gcm(modname,abort_message,1)
+         endif
+
+         inirnpb=rnpb
+         PRINT*, 'La frequence de sortie traceurs est  ', ecrit_tra
+         itra=0
+	 itap=0
+C         
+         CALL ymds2ju(annee_ref, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + day_ref
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = xlon(i+1)
+            zx_lon(i,jjm+1) = xlon(i+1)
+         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(:,1), jjm+1,zx_lat(1,:),
+     .                 1,iim,1,jjm+1, itau_phy, zjulian, pdtphys,
+     .                 nhori, nid_tra)
+         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+     .                 klev, presnivs, nvert)
+         zsto = pdtphys
+         zout = pdtphys * FLOAT(ecrit_tra)
+c
+         CALL histdef(nid_tra, "phis", "Surface geop. height", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_tra, "aire", "Grid area", "-",
+     .                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
+         IF (it.LE.99) THEN
+         WRITE(str2,'(i2.2)') it
+C champ 3D
+         CALL histdef(nid_tra, "tr"//str2, "Tracer No."//str2, "U/kga",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         IF (lessivage) THEN
+         CALL histdef(nid_tra, "fl"//str2, "Tracer Flux No."//str2, 
+     .                "U/m2/s",iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         ENDIF
+         ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+         ENDIF
+         ENDDO
+         CALL histend(nid_tra)
+         ndex(1) = 0
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_tra,"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_tra,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+
+c======================================================================
+c   Initialisation de certaines variables pour le Rn et le Pb 
+c======================================================================
+
+c Initialisation du traceur dans le sol (couche limite radonique)
+c
+c        print*,'valeur de debut dans phytrac :',debutphy
+         do it=1,nqmax
+            do i=1,klon
+               trs(i,it) = 0.
+            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
+         DO it=1,nqmax
+           DO k = 1, nlev
+              DO i = 1, klon
+                 d_tr_lessi_impa(i,k,it) =  0.0
+                 d_tr_lessi_nucl(i,k,it) =  0.0 
+             ENDDO
+           ENDDO
+         ENDDO
+c
+c Initialisation de la nature des traceurs
+c
+         DO it = 1, nqmax
+            aerosol(it) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+            radio(it) = .FALSE.    ! Par defaut pas de passage par radiornpb
+            clsol(it) = .FALSE.  ! Par defaut couche limite avec flux prescrit
+         ENDDO
+c
+      ENDIF  ! fin debutphy 
+c Initialisation du traceur dans le sol (couche limite radonique)
+      if(inirnpb) THEN
+c
+         radio(1)= .true.
+         radio(2)= .true.
+         clsol(1)= .true.
+         clsol(2)= .true.
+         aerosol(2) = .TRUE. ! le Pb est un aerosol 
+c
+         call initrrnpb (ftsol,pctsrf,masktr,fshtr,hsoltr,tautr
+     .                   ,vdeptr,scavtr)
+         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
+
+      print*,'Pas de temps dans phytrac : ',pdtphys
+      DO it=1, nqmax
+      CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .            pplay, paprs, tr_seri(1,1,it), d_tr_cv)
+      DO k = 1, nlev
+      DO i = 1, klon
+         tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k)
+      ENDDO
+      ENDDO
+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======================================================================
+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
+
+      DO k = 1, nlev
+      DO i = 1, klon
+         delp(i,k) = paprs(i,k)-paprs(i,k+1)
+      ENDDO
+      ENDDO
+
+C maf modif pour tenir compte du cas rnpb + traceur
+      DO it=1, nqmax
+c     print *,'it',it,clsol(it)
+      if (clsol(it)) then  ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, pdtphys, yu1, yv1,
+     e                    coefh,t_seri,ftsol,pctsrf,
+     e                    tr_seri(1,1,it),trs(1,it),
+     e                    paprs, pplay, delp,
+     e                    masktr(1,it),fshtr(1,it),hsoltr(it),
+     e                    tautr(it),vdeptr(it),
+     e                    xlat,
+     s                    d_tr_cl,d_trs)
+          DO k = 1, nlev
+            DO i = 1, klon
+              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k)
+            ENDDO
+          ENDDO
+c
+c Traceur ds sol
+c
+          DO i = 1, klon
+            trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+C
+C maf provisoire suppression des prints
+C         WRITE(itn,'(i1)') it
+C         CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracrn it='//itn)
+      else ! couche limite avec flux prescrit
+Cmaf provisoire source / traceur a creer
+        DO i=1, klon
+          source(i) = 0.0 ! pas de source, pour l'instant
+        ENDDO
+C
+          CALL cltrac(pdtphys, coefh,t_seri,
+     s               tr_seri(1,1,it), source,
+     e               paprs, pplay, delp,
+     s               d_tr )
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr(i,k)
+               ENDDO
+            ENDDO
+Cmaf provisoire suppression des prints
+Cmaf          WRITE(itn,'(i1)') it
+cmaf          CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'cltracn it='//itn)
+      endif
+      ENDDO
+c
+      endif ! couche limite
+
+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======================================================================
+c   Calcul de l'effet du puits radioactif
+c======================================================================
+
+C MAF il faudrait faire une modification pour passer dans radiornpb 
+c si radio=true mais pour l'instant radiornpb propre au cas rnpb
+      if(rnpb) then
+        call radiornpb (tr_seri,pdtphys,tautr,d_tr_dec)
+C
+        DO it=1,nqmax
+            if(radio(it)) then
+            DO k = 1, nlev
+               DO i = 1, klon
+                  tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+               ENDDO
+            ENDDO
+            WRITE(itn,'(i1)') it
+            CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'puits rn it='//itn)
+            endif
+        ENDDO
+c
+      endif ! rnpb decroissance  radioactive
+C
+c======================================================================
+c   Calcul de l'effet de la precipitation
+c======================================================================
+
+      print*,'LESSIVAGE =',lessivage
+      IF (lessivage) THEN
+
+c     print*,'avant lessivage'
+
+       DO it = 1, nqmax
+           DO k = 1, nlev
+              DO i = 1, klon
+               d_tr_lessi_nucl(i,k,it) = 0.0 
+               d_tr_lessi_impa(i,k,it) = 0.0 
+               flestottr(i,k,it) = 0.0 
+              ENDDO
+           ENDDO
+       ENDDO
+c
+c tendance des aerosols nuclees et impactes 
+c
+       DO it = 1, nqmax
+         IF (aerosol(it)) THEN
+           DO k = 1, nlev
+              DO i = 1, klon
+               d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +
+     s                  ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+               d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +
+     s                  ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c
+c Mises a jour des traceurs + calcul des flux de lessivage 
+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)
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+c      call dump2d(iim,jjm-1,tr_seri(2:klon-1,10,3),'TRACEUR3B')
+c
+c Flux lessivage total 
+c
+      DO it = 1, nqmax
+           DO k = 1, nlev
+            DO i = 1, klon
+               flestottr(i,k,it) = flestottr(i,k,it) -
+     s                   ( d_tr_lessi_nucl(i,k,it)   +
+     s                     d_tr_lessi_impa(i,k,it) ) *
+     s                   ( paprs(i,k)-paprs(i,k+1) ) / 
+     s                   (RG * pdtphys)
+            ENDDO
+           ENDDO
+c
+Cmaf suppression provisoire
+Cmaf        WRITE(itn,'(i1)') it
+Cmaf    CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'tr(lessi) it='//itn)
+      ENDDO
+c
+c     print*,'apres lessivage'
+      ENDIF
+Cc
+      DO k = 1, nlev
+         DO i = 1, klon
+            fluxrn(i,k) = flestottr(i,k,1)
+            fluxpb(i,k) = flestottr(i,k,2)
+            rn(i,k) = tr_seri(i,k,1)
+            pb(i,k) = tr_seri(i,k,2)
+            pbnucl(i,k)=d_tr_lessi_nucl(i,k,2)
+            pbimpa(i,k)=d_tr_lessi_impa(i,k,2)
+         ENDDO
+      ENDDO
+      itra=itra+1
+      ndex(1) = 0
+      DO it=1,nqmax
+      IF (it.LE.99) THEN
+       WRITE(str2,'(i2.2)') it
+C champs 3D
+       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,tr_seri(1,1,it),zx_tmp_3d)
+       CALL histwrite(nid_tra,"tr"//str2,itra,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+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"
+         CALL abort
+      ENDIF
+      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/IPSL-CM4_v1x1/libf/phylmd/plevel.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/plevel.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/plevel.F	(revision 428)
@@ -0,0 +1,114 @@
+c================================================================
+c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+
+      IMPLICIT none
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+      INTEGER lt(klon), lb(klon)
+      REAL ptop, pbot, aist(klon), aisb(klon)
+
+      save lt,lb,ptop,pbot,aist,aisb
+
+      INTEGER i, k
+c
+
+c=====================================================================
+      if (lnew) then
+c   on réinitialise les réindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, klon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frédéric Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+            Qpres(i)=1e33
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/printflag.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/printflag.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/printflag.F	(revision 428)
@@ -0,0 +1,187 @@
+       SUBROUTINE  printflag( tabcntr0, radpas, ok_ocean,ok_oasis,
+     ,                        ok_journe,ok_instan,ok_region        )
+c
+
+c
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_ocean,ok_oasis,ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+c
+#include "clesphys.h"
+c
+c
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT *,' ********   Choix  des principales  cles de la physique 
+     ,   *********'
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD            
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke  
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 3 )   THEN
+           PRINT *,' *****           Shema  convection    CCM      
+     ,          ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 5,  ok_ocean,ok_oasis
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+c
+c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+     ,$$$$$$$$$$$$$'
+        PRINT 100
+c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.
+     ,        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.
+     ,        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.
+     ,        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.
+     ,        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.
+     ,        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0.
+     ,     AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+
+ 4    FORMAT(2x,5(1H*),'  ok_journe= ',l3,3x,',ok_instan = ',
+     , l3,3x,',ok_region = ',l3,3x,5(1H*) )
+
+ 5    FORMAT(2x,5(1H*),'      ok_ocean = ',l3,6x,' , ok_oasis = ',
+     , l3,14x,5(1H*) )
+
+
+ 7     FORMAT(2x,5(1H*),15x,'      ok_limitvrai   = ',l3,16x,5(1h*) )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,
+     , i4,6x,' *****')
+
+ 10    FORMAT(2x,5(1H*),'    Cycle_diurne = ',l3,4x,', Soil_model = ',
+     , l3,12x,6(1H*) )
+
+
+ 11    FORMAT(2x,5(1H*),'  new_oliq = ',l3,3x,', Ok_orodr = ',
+     , l3,3x,', Ok_orolf = ',l3,3x,5(1H*) )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,
+     , i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.160.98.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.160.98.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.160.98.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=78,kflev=klev) ! 78*199
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.192.143.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.192.143.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.192.143.h	(revision 428)
@@ -0,0 +1,2 @@
+       INTEGER kdlon, kflev
+      PARAMETER (kdlon=10,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.32.24.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.32.24.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.32.24.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.48.32.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.48.32.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.48.32.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.72.46.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.72.46.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.72.46.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=1621,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.96.72.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.96.72.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.96.72.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=487,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.defaut.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.defaut.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.defaut.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddim.h	(revision 428)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=klon,kflev=klev)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddimlw.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddimlw.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/raddimlw.h	(revision 428)
@@ -0,0 +1,8 @@
+      INTEGER NUA
+      PARAMETER (NUA=24)
+      INTEGER NTRA
+      PARAMETER (NTRA=15)
+      INTEGER Ninter
+      PARAMETER (Ninter=6)
+      INTEGER NG1, NG1P1
+      PARAMETER (NG1=2, NG1P1=NG1+1)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radepsi.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radepsi.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radepsi.h	(revision 428)
@@ -0,0 +1,13 @@
+      REAL*8 ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW
+      REAL*8 ZEPSEC, ZEPSCR
+      PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines)
+      PARAMETER (ZEPSC  = 1.E-20)
+      PARAMETER (ZEPSCO = 1.E-10)
+      PARAMETER (ZEPSCQ = 1.E-10)
+      PARAMETER (ZEPSCT = 1.E-20)
+      PARAMETER (ZEPSCW = 1.E-20)
+      PARAMETER (ZEPSEC = 1.0E-12)
+      PARAMETER (ZEPSCR = 1.0E-10)
+c
+      REAL*8 REPSCT
+      PARAMETER (REPSCT=1.0E-10)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radiornpb.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radiornpb.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radiornpb.F	(revision 428)
@@ -0,0 +1,50 @@
+      SUBROUTINE radiornpb(tr,dtime,tautr,d_tr) 
+      IMPLICIT none
+c======================================================================
+c Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+c Objet: Decroissance radioactive d'un traceur dans l'atmosphere
+CG240694 : Pour un traceur, le radon
+CG161294 : Plus un 2eme traceur, le 210Pb. Le radon decroit en plomb.
+c======================================================================
+c Arguments:
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+c======================================================================
+C
+      INTEGER i , k , it
+      REAL tr(klon,klev,nbtr) , d_tr(klon,klev,nbtr)
+      REAL dtime
+      REAL tautr(nbtr)
+C
+      WRITE(*,'(''PASSAGE radiornpb ... '',$)')
+C Attention, pour un pas de temps beaucoup plus petit que la decroissance!!!
+
+      DO it = 1,2
+           IF ( tautr(it) .GT. 0. ) THEN
+          	DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+                END DO
+                END DO
+           ELSE
+                DO k = 1,klev
+                DO i = 1,klon
+                d_tr(i,k,it) = 0.
+                END DO
+                END DO
+           END IF
+      END DO
+C
+CG161294 : Cas particulier radon 1 => plomb 2
+c
+      DO k = 1,klev
+        DO i = 1,klon
+          d_tr(i,k,2) = d_tr(i,k,2) - d_tr(i,k,1)
+        ENDDO
+      ENDDO
+c
+      WRITE(*,*) ' radiornpb OK'
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radlwsw.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radlwsw.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radlwsw.F	(revision 428)
@@ -0,0 +1,6172 @@
+      SUBROUTINE radlwsw(dist, rmu0, fract, co2_ppm, solaire,
+     .                  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,
+     .                  ZFSUP,ZFSDN,ZFSUP0,ZFSDN0)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
+c Objet: interface entre le modele et les rayonnements
+c Arguments:
+c dist-----input-R- distance astronomique terre-soleil
+c rmu0-----input-R- cosinus de l'angle zenithal
+c fract----input-R- duree d'ensoleillement normalisee
+c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
+c solaire--input-R- constante solaire (W/m**2)
+c paprs----input-R- pression a inter-couche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c tsol-----input-R- temperature du sol (en K)
+c albedo---input-R- albedo du sol (entre 0 et 1)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (en kg/kg)
+c wo-------input-R- contenu en ozone (en cm.atm)
+c cldfra---input-R- fraction nuageuse (entre 0 et 1)
+c cldtau---input-R- epaisseur optique des nuages dans le visible
+c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
+c
+c heat-----output-R- echauffement atmospherique (visible) (K/jour)
+c cool-----output-R- refroidissement dans l'IR (K/jour)
+c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
+c albpla---output-R- albedo planetaire (entre 0 et 1)
+c topsw----output-R- flux solaire net au sommet de l'atm.
+c toplw----output-R- ray. IR montant au sommet de l'atmosphere
+c solsw----output-R- flux solaire net a la surface
+c sollw----output-R- ray. IR montant a la surface
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "YOETHF.h"
+c
+      real rmu0(klon), fract(klon), dist
+      real co2_ppm
+      real solaire
+c
+      real paprs(klon,klev+1), pplay(klon,klev)
+      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)
+      real heat(klon,klev), cool(klon,klev)
+      real heat0(klon,klev), cool0(klon,klev)
+      real radsol(klon), topsw(klon), toplw(klon)
+      real solsw(klon), sollw(klon), albpla(klon)
+      real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      real sollwdown(klon)
+cccIM 
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+c
+      REAL*8 zx_alpha1, zx_alpha2
+c
+#include "YOMCST.h"
+c
+      INTEGER k, kk, i, j, iof, nb_gr
+      EXTERNAL lw, sw
+c
+      REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
+      REAL*8 PSCT
+c
+      REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
+      REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
+      REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
+      REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
+      REAL*8 PTAVE(kdlon,kflev)
+      REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
+      REAL*8 PAER(kdlon,kflev,5)
+      REAL*8 PCLDLD(kdlon,kflev)
+      REAL*8 PCLDLU(kdlon,kflev)
+      REAL*8 PCLDSW(kdlon,kflev)
+      REAL*8 PTAU(kdlon,2,kflev)
+      REAL*8 POMEGA(kdlon,2,kflev)
+      REAL*8 PCG(kdlon,2,kflev)
+c
+      REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
+c
+      REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
+      REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
+      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)
+      REAL*8 zznormcp
+c
+c-------------------------------------------
+      nb_gr = klon / kdlon
+      IF (nb_gr*kdlon .NE. klon) THEN
+         PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
+         CALL abort
+      ENDIF
+      IF (kflev .NE. klev) THEN
+          PRINT*, "kflev differe de klev, kflev, klev"
+          CALL abort
+      ENDIF
+c-------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         heat(i,k)=0.
+         cool(i,k)=0.
+         heat0(i,k)=0.
+         cool0(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      zdist = dist
+c
+      RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97
+      RCH4 = 1.72E-06* 16.043/28.97
+      RN2O = 310.E-09* 44.013/28.97
+      RCFC11 = 280.E-12* 137.3686/28.97
+      RCFC12 = 484.E-12* 120.9140/28.97
+      PSCT = solaire/zdist/zdist
+c
+      DO 99999 j = 1, nb_gr
+      iof = kdlon*(j-1)
+c
+      DO i = 1, kdlon
+         zfract(i) = fract(iof+i)
+         zrmu0(i) = rmu0(iof+i)
+         PALBD(i,1) = 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) = alblw(iof+i)
+         PEMIS(i) = 0.96
+         PVIEW(i) = 1.66
+         PPSOL(i) = paprs(iof+i,1)
+         zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2)) 
+     .             / (pplay(iof+i,1)-pplay(iof+i,2))
+         zx_alpha2 = 1.0 - zx_alpha1
+         PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
+         PTL(i,klev+1) = t(iof+i,klev)
+         PDT0(i) = tsol(iof+i) - PTL(i,1)
+      ENDDO
+      DO k = 2, kflev
+      DO i = 1, kdlon
+         PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
+      ENDDO
+      ENDDO
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
+         PTAVE(i,k) = t(iof+i,k)
+         PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
+         PQS(i,k) = PWV(i,k)
+c wo:    cm.atm (epaisseur en cm dans la situation standard)
+c POZON: kg/kg
+         POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
+     .               /(paprs(iof+i,k)-paprs(iof+i,k+1))
+     .               *(paprs(iof+i,1)/101325.0)
+         PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+         PCLDSW(i,k) = cldfra(iof+i,k)
+         PTAU(i,1,k) = MAX(cldtau(iof+i,k), 1.0e-05)! 1e-12 serait instable
+         PTAU(i,2,k) = MAX(cldtau(iof+i,k), 1.0e-05)! pour 32-bit machines
+         POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
+         POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
+         PCG(i,1,k) = 0.865
+         PCG(i,2,k) = 0.910
+      ENDDO
+      ENDDO
+c
+      DO k = 1, kflev+1
+      DO i = 1, kdlon
+         PPMB(i,k) = paprs(iof+i,k)/100.0
+      ENDDO
+      ENDDO
+c
+      DO kk = 1, 5
+      DO k = 1, kflev
+      DO i = 1, kdlon
+         PAER(i,k,kk) = 1.0E-15
+      ENDDO
+      ENDDO
+      ENDDO
+c
+c======================================================================
+      CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+     .        PPMB, PDP,
+     .        PPSOL,PDT0,PEMIS,
+     .        PTL, PTAVE, PWV, POZON, PAER,
+     .        PCLDLD,PCLDLU,
+     .        PVIEW,
+     .        zcool, zcool0,
+     .        ztoplw,zsollw,ztoplw0,zsollw0,
+     .        zsollwdown)
+      CALL SW(PSCT, RCO2, zrmu0, zfract,
+     S        PPMB, PDP,
+     S        PPSOL, PALBD, PALBP,
+     S        PTAVE, PWV, PQS, POZON, PAER,
+     S        PCLDSW, PTAU, POMEGA, PCG,
+     S        zheat, zheat0,
+     S        zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,
+     S        ZFSUP,ZFSDN,ZFSUP0,ZFSDN0)
+c======================================================================
+      DO i = 1, kdlon
+         radsol(iof+i) = zsolsw(i) + zsollw(i)
+         topsw(iof+i) = ztopsw(i)
+         toplw(iof+i) = ztoplw(i)
+         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)
+         solsw0(iof+i) = zsolsw0(i)
+         sollw0(iof+i) = zsollw0(i)
+         albpla(iof+i) = zalbpla(i)
+      ENDDO
+      DO k = 1, kflev
+c      DO i = 1, kdlon
+c         heat(iof+i,k) = zheat(i,k)
+c         cool(iof+i,k) = zcool(i,k)
+c         heat0(iof+i,k) = zheat0(i,k)
+c         cool0(iof+i,k) = zcool0(i,k)
+c      ENDDO
+      DO i = 1, kdlon
+C        scale factor to take into account the difference between
+C        dry air and watter vapour scpecific heat capacity
+         zznormcp=1.0+RVTMP2*PWV(i,k)
+         heat(iof+i,k) = zheat(i,k)/zznormcp
+         cool(iof+i,k) = zcool(i,k)/zznormcp
+         heat0(iof+i,k) = zheat0(i,k)/zznormcp
+         cool0(iof+i,k) = zcool0(i,k)/zznormcp
+      ENDDO
+      ENDDO
+c
+99999 CONTINUE
+      RETURN
+      END
+      SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+     S              PPMB, PDP, 
+     S              PPSOL, PALBD, PALBP,
+     S              PTAVE, PWV, PQS, POZON, PAER,
+     S              PCLDSW, PTAU, POMEGA, PCG,
+     S              PHEAT, PHEAT0,
+     S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
+     S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0)
+      IMPLICIT none
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "YOMCST.h"
+C
+C     ------------------------------------------------------------------
+C
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT  ! constante solaire (valeur conseillee: 1370)
+      REAL*8 RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+C
+      REAL*8 PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL*8 PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+C
+      REAL*8 PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL*8 PFRAC(KDLON)  ! fraction de la journee
+C
+      REAL*8 PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL*8 PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL*8 PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL*8 POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+C
+      REAL*8 PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL*8 PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+C
+      REAL*8 PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL*8 PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL*8 PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL*8 POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+C
+      REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL*8 PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL*8 PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL*8 PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL*8 PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL*8 PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZOZ(KDLON,KFLEV)
+      REAL*8 ZAKI(KDLON,2)     
+      REAL*8 ZCLD(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON) 
+      REAL*8 ZDSIG(KDLON,KFLEV)
+      REAL*8 ZFACT(KDLON)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFDOWN(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1)
+      REAL*8 ZFUP(KDLON,KFLEV+1)
+      REAL*8 ZRMU(KDLON)
+      REAL*8 ZSEC(KDLON)
+      REAL*8 ZUD(KDLON,5,KFLEV+1)
+      REAL*8 ZCLDSW0(KDLON,KFLEV)
+c
+      REAL*8 ZFSUP(KDLON,KFLEV+1)
+      REAL*8 ZFSDN(KDLON,KFLEV+1)
+      REAL*8 ZFSUP0(KDLON,KFLEV+1)
+      REAL*8 ZFSDN0(KDLON,KFLEV+1)
+C
+      INTEGER inu, jl, jk, i, k, kpl1
+c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         PRINT*, 'SW calling frequency : ', swpas
+         PRINT*, "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+c
+      DO JK = 1 , KFLEV
+      DO JL = 1, KDLON
+         ZCLDSW0(JL,JK) = 0.0
+         ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
+     .               *PDP(JL,JK)*(101325.0/PPSOL(JL))
+      ENDDO
+      ENDDO
+C
+C
+c clear-sky:
+      CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+c cloudy-sky:
+      CALL SWU(PSCT,RCO2,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S(INU,
+     S     PAER, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S(INU,
+     S     PAER, ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+c
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
+     .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+      ENDDO
+C
+      RETURN
+      END
+c
+      SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
+     S                PRMU,PSEC,PUD)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+C
+C* ARGUMENTS:
+C
+      REAL*8 PSCT
+      REAL*8 RCO2
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 PRMU0(KDLON)
+      REAL*8 PFRAC(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PFACT(KDLON)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(2)
+      REAL*8 ZC1J(KDLON,KFLEV+1)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZN175(KDLON)
+      REAL*8 ZN190(KDLON)
+      REAL*8 ZO175(KDLON)
+      REAL*8 ZO190(KDLON)
+      REAL*8 ZSIGN(KDLON)
+      REAL*8 ZR(KDLON,2) 
+      REAL*8 ZSIGO(KDLON)
+      REAL*8 ZUD(KDLON,2)
+      REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+C
+C* Prescribed Data:
+c
+      REAL*8 ZPDH2O,ZPDUMG
+      SAVE ZPDH2O,ZPDUMG
+      REAL*8 ZPRH2O,ZPRUMG
+      SAVE ZPRH2O,ZPRUMG
+      REAL*8 RTDH2O,RTDUMG
+      SAVE RTDH2O,RTDUMG
+      REAL*8 RTH2O ,RTUMG
+      SAVE RTH2O ,RTUMG
+      DATA ZPDH2O,ZPDUMG / 0.8   , 0.75 /
+      DATA ZPRH2O,ZPRUMG / 30000., 30000. /
+      DATA RTDH2O,RTDUMG /  0.40  , 0.375 /
+      DATA RTH2O ,RTUMG  /  240.  , 240.  /
+C     ------------------------------------------------------------------
+C
+C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+C                 -----------------------------
+C
+ 100  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=2
+C      
+C
+C*         1.1    INITIALIZES QUANTITIES
+C                 ----------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+C
+C*          1.3    AMOUNTS OF ABSORBERS
+C                  --------------------
+C
+ 130  CONTINUE
+C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
+     .             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
+     .             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)
+     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
+     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+C      
+C
+C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+C                 -----------------------------------------------
+C
+ 140  CONTINUE
+C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+C
+      CALL SWTT1(2, 2, IIND, ZUD, ZR)
+C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW1S ( KNU
+     S  ,  PAER  , PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
+     S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD  
+     S  ,  PFD   , PFU)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)  
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+C
+      REAL*8 PFD(KDLON,KFLEV+1)
+      REAL*8 PFU(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(4)
+C      
+      REAL*8 ZCGAZ(KDLON,KFLEV) 
+      REAL*8 ZDIFF(KDLON)
+      REAL*8 ZDIRF(KDLON)        
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZR(KDLON,4)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZW(KDLON,4)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+c
+c Prescribed Data:
+c
+      REAL*8 RSUN(2)
+      SAVE RSUN
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C     ------------------------------------------------------------------
+C
+C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+C                 ----------------------- ------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
+     S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
+     S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , PALBP , PDSIG , ZRAYL, PSEC
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
+     S  , PSEC  ,PTAU
+     S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
+     S  , ZTAUAZ,ZTRA1 ,ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    OZONE ABSORPTION
+C                ----------------
+C
+ 300  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+C      
+C
+C*         3.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 310  CONTINUE
+C
+      JAJ = 2
+C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
+     S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+C
+C
+C*         3.2   UPWARD FLUXES
+C                -------------
+C
+ 320  CONTINUE
+C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
+     S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
+     S          * RSUN(KNU)
+ 325  CONTINUE
+C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+C
+      CALL SWTT1(KNU, 4, IIND, ZW, ZR)
+C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW2S ( KNU
+     S  ,  PAER  ,PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
+     S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
+     S  ,  PUD   ,PWV , PQS
+     S  ,  PFDOWN,PFUP                                            )
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "radepsi.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+C     A GREY MOLECULAR ABSORPTION
+C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+C     OF ABSORBERS
+C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PAKI(KDLON,2)
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PCLDSW(KDLON,KFLEV)
+      REAL*8 PCLEAR(KDLON)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PQS(KDLON,KFLEV)
+      REAL*8 PRMU(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+      REAL*8 PUD(KDLON,5,KFLEV+1)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PFDOWN(KDLON,KFLEV+1)
+      REAL*8 PFUP(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND2(2), IIND3(3)
+      REAL*8 ZCGAZ(KDLON,KFLEV)
+      REAL*8 ZFD(KDLON,KFLEV+1)
+      REAL*8 ZFU(KDLON,KFLEV+1) 
+      REAL*8 ZG(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZPIZAZ(KDLON,KFLEV)
+      REAL*8 ZRAYL(KDLON)
+      REAL*8 ZRAY1(KDLON,KFLEV+1)
+      REAL*8 ZRAY2(KDLON,KFLEV+1)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZREFZ(KDLON,2,KFLEV+1)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRJ(KDLON,6,KFLEV+1)
+      REAL*8 ZRJ0(KDLON,6,KFLEV+1)
+      REAL*8 ZRK(KDLON,6,KFLEV+1)
+      REAL*8 ZRK0(KDLON,6,KFLEV+1)
+      REAL*8 ZRL(KDLON,8)
+      REAL*8 ZRMUE(KDLON,KFLEV+1)
+      REAL*8 ZRMU0(KDLON,KFLEV+1)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZRUEF(KDLON,8)
+      REAL*8 ZR1(KDLON) 
+      REAL*8 ZR2(KDLON,2)
+      REAL*8 ZR3(KDLON,3)
+      REAL*8 ZR4(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZS(KDLON)
+      REAL*8 ZTAUAZ(KDLON,KFLEV)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTRA1(KDLON,KFLEV+1)
+      REAL*8 ZTRA2(KDLON,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)   
+      REAL*8 ZW1(KDLON)
+      REAL*8 ZW2(KDLON,2)
+      REAL*8 ZW3(KDLON,3)
+      REAL*8 ZW4(KDLON)
+      REAL*8 ZW5(KDLON)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+C
+C* Prescribed Data:
+C
+      REAL*8 RSUN(2)
+      SAVE RSUN
+      REAL*8 RRAY(2,6)
+      SAVE RRAY
+      DATA RSUN(1) / 0.441676 /
+      DATA RSUN(2) / 0.558324 /
+      DATA (RRAY(1,K),K=1,6) /
+     S .428937E-01, .890743E+00,-.288555E+01,
+     S .522744E+01,-.469173E+01, .161645E+01/
+      DATA (RRAY(2,K),K=1,6) /
+     S .697200E-02, .173297E-01,-.850903E-01,
+     S .248261E+00,-.302031E+00, .129662E+00/
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+C                 -------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
+     S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
+     S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR ( KNU
+     S  , PAER   , PALBP , PDSIG , ZRAYL, PSEC 
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
+     S  , PSEC  , PTAU
+     S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
+     S  , ZTAUAZ, ZTRA1 , ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+C                ------------------------------------------------------
+C
+ 300  CONTINUE
+C
+      JN = 2
+C
+      DO 361 JABS=1,2
+C
+C
+C*         3.1  SURFACE CONDITIONS
+C               ------------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+C
+C
+C*         3.2  INTRODUCING CLOUD EFFECTS
+C               -------------------------
+C
+ 320  CONTINUE
+C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
+     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
+     S               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+C
+      CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
+     S          ZRE1, ZRE2, ZTR1, ZTR2)
+C
+      DO 323 JL = 1, KDLON
+C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
+     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
+     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
+     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
+     S             + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
+     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
+     S              * ZREFZ(JL,1,JKM1)))
+     S              * ZG(JL) * (1. -ZRNEB(JL))
+C
+ 323  CONTINUE
+ 324  CONTINUE
+C
+C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C               -------------------------------------------------
+C
+ 330  CONTINUE
+C
+      DO 351 JREF=1,2
+C
+      JN = JN + 1
+C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         4.    INVERT GREY AND CONTINUUM FLUXES
+C                --------------------------------
+C
+ 400  CONTINUE
+C
+C
+C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+C                ---------------------------------------------
+C
+ 410  CONTINUE
+C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+C
+C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+C                 ---------------------------------------------
+C
+ 420  CONTINUE
+C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+C
+C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+C                 --------------------------
+C
+ 4210 CONTINUE
+C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+C
+C*         4.2.2  TRANSMISSION FUNCTION
+C                 ---------------------
+C
+ 4220 CONTINUE
+C
+      CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
+C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+C
+C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+C                 ------------------------------------------------------
+C
+ 430  CONTINUE
+C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
+     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
+     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+C                ----------------------------------------
+C
+ 500  CONTINUE
+C
+C
+C*         5.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 510  CONTINUE
+C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 513 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+C
+C
+C*         5.2   UPWARD FLUXES
+C                -------------
+C
+ 520  CONTINUE
+C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+C
+      CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 527 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+C                 --------------------------------------------------
+C
+ 600  CONTINUE
+      IABS=3
+C
+C*         6.1    DOWNWARD FLUXES
+C                 ---------------
+C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
+     S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
+     S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+C
+C
+C*         6.2    UPWARD FLUXES
+C                 -------------
+C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
+     S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+C
+      CALL SWTT(KNU, IABS, ZW1, ZR1)
+C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
+     S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWCLR  ( KNU
+     S  , PAER  , PALBP , PDSIG , PRAYL , PSEC
+     S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ  
+     S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CLEAR-SKY COLUMN
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 94-11-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PALBP(KDLON,2)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+C
+      REAL*8 PCGAZ(KDLON,KFLEV)     
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMU0(KDLON,KFLEV+1)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC0I(KDLON,KFLEV+1)       
+      REAL*8 ZCLE0(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS0(KDLON)
+      REAL*8 ZSCAT(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL*8 ZBMU0, ZBMU1, ZRE11
+C
+C* Prescribed Data for Aerosols:
+C
+      REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
+      SAVE TAUA, RPIZA, RCGA
+      DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
+     S .730719, .912819, .725059, .745405, .682188 ,
+     S .730719, .912819, .725059, .745405, .682188 /
+      DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
+     S .872212, .982545, .623143, .944887, .997975 ,
+     S .872212, .982545, .623143, .944887, .997975 /
+      DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
+     S .647596, .739002, .580845, .662657, .624246 ,
+     S .647596, .739002, .580845, .662657, .624246 /
+C     ------------------------------------------------------------------
+C
+C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+C                --------------------------------------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+      DO 108 JK = 1 , KFLEV
+      DO 104 JL = 1, KDLON
+      PCGAZ(JL,JK) = 0.
+      PPIZAZ(JL,JK) =  0.
+      PTAUAZ(JL,JK) = 0.
+ 104  CONTINUE
+      DO 106 JAE=1,5
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+ 105  CONTINUE
+ 106  CONTINUE
+C
+      DO 107 JL = 1, KDLON
+      IF (KAER.NE.0) THEN
+         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
+     S                       / (1. - PPIZAZ(JL,JK) * ZFF)
+      ELSE
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END IF
+ 107  CONTINUE
+c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+C
+ 108  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
+     S            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWR ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
+     S  , PSEC  , PTAU
+     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
+     S  , PTAUAZ, PTRA1 , PTRA2 )
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CONTINUUM SCATTERING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL*8 PALBD(KDLON,2)
+      REAL*8 PCG(KDLON,2,KFLEV)
+      REAL*8 PCLD(KDLON,KFLEV)
+      REAL*8 PDSIG(KDLON,KFLEV)
+      REAL*8 POMEGA(KDLON,2,KFLEV)
+      REAL*8 PRAYL(KDLON)
+      REAL*8 PSEC(KDLON)
+      REAL*8 PTAU(KDLON,2,KFLEV)
+C
+      REAL*8 PRAY1(KDLON,KFLEV+1)
+      REAL*8 PRAY2(KDLON,KFLEV+1)
+      REAL*8 PREFZ(KDLON,2,KFLEV+1)
+      REAL*8 PRJ(KDLON,6,KFLEV+1)
+      REAL*8 PRK(KDLON,6,KFLEV+1)
+      REAL*8 PRMUE(KDLON,KFLEV+1)
+      REAL*8 PCGAZ(KDLON,KFLEV)
+      REAL*8 PPIZAZ(KDLON,KFLEV)
+      REAL*8 PTAUAZ(KDLON,KFLEV)
+      REAL*8 PTRA1(KDLON,KFLEV+1)
+      REAL*8 PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZC1I(KDLON,KFLEV+1)
+      REAL*8 ZCLEQ(KDLON,KFLEV)
+      REAL*8 ZCLEAR(KDLON)
+      REAL*8 ZCLOUD(KDLON)
+      REAL*8 ZGG(KDLON)
+      REAL*8 ZREF(KDLON)
+      REAL*8 ZRE1(KDLON)
+      REAL*8 ZRE2(KDLON)
+      REAL*8 ZRMUZ(KDLON)
+      REAL*8 ZRNEB(KDLON)
+      REAL*8 ZR21(KDLON)
+      REAL*8 ZR22(KDLON)
+      REAL*8 ZR23(KDLON)
+      REAL*8 ZSS1(KDLON)
+      REAL*8 ZTO1(KDLON)
+      REAL*8 ZTR(KDLON,2,KFLEV+1)
+      REAL*8 ZTR1(KDLON)
+      REAL*8 ZTR2(KDLON)
+      REAL*8 ZW(KDLON)
+C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
+C
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.3  EFFECT OF CLOUD LAYER
+C               ---------------------
+C
+ 330  CONTINUE
+C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
+     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+C machine
+C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+C
+      CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
+     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+C
+      DO 345 JL = 1, KDLON
+C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               * (1.-ZRNEB(JL))
+C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
+     S                 PRE1,PRE2,PTR1,PTR2)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      REAL*8 PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL*8 PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL*8 PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL*8 PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL*8 PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL*8 PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL*8 PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER jl
+      REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
+      REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL*8 ZRI0B, ZRI1B
+      REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
+C     ------------------------------------------------------------------
+C
+C*         1.      DELTA-EDDINGTON CALCULATIONS
+C
+ 100  CONTINUE
+C
+      DO 131 JL   =   1, KDLON
+C
+C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+C
+ 110  CONTINUE
+C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+CMAF      ZARG=MIN(ZTOP/PRMUZ(JL),200.)
+      ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
+      ZEXMU0=EXP(-ZARG)
+CMAF      ZARG2=MIN(ZRK*ZTOP,200.)
+      ZARG2=MIN(ZRK*ZTOP,2.0d+2)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+C
+C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+C
+ 120  CONTINUE
+C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+C
+C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+C
+ 130  CONTINUE
+C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+C
+ 131  CONTINUE
+      RETURN
+      END
+      SUBROUTINE SWTT (KNU,KA,PU,PTR)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS
+C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL*8 PU(KDLON)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
+     S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
+     S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
+     S      * ( APAD(KNU,KA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
+     S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
+     S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
+     S      * ( BPAD(KNU,KA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 95-01-20
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT
+C
+      REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZR1(KDLON)
+      REAL*8 ZR2(KDLON)
+      REAL*8 ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+C
+C* Prescribed Data:
+C
+      REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
+      SAVE APAD, BPAD, D
+      DATA ((APAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
+     S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
+     S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
+      DATA ((APAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
+     S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
+     S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
+     S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
+     S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
+     S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
+C
+      DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
+     S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
+     S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
+     S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
+     S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
+     S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
+      DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
+     S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
+     S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
+     S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
+     S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
+     S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
+     S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
+     S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
+c
+      DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
+      DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
+     S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
+     S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
+     S      * ( APAD(KNU,IA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
+     S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
+     S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
+     S      * ( BPAD(KNU,IA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+     .              PPMB, PDP,
+     .              PPSOL,PDT0,PEMIS,
+     .              PTL, PTAVE, PWV, POZON, PAER,
+     .              PCLDLD,PCLDLU,
+     .              PVIEW,
+     .              PCOLR, PCOLR0,
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+      REAL*8 RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+      REAL*8 RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+      REAL*8 RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+      REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+      REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+      REAL*8 PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL*8 PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL*8 PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL*8 PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL*8 PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL*8 PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL*8 POZON(KDLON,KFLEV)   ! O3 CONCENTRATION (kg/kg)
+      REAL*8 PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL*8 PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL*8 PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL*8 PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL*8 PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+C
+      REAL*8 PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL*8 PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL*8 PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL*8 PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      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-------------------------------------------------------------------------
+      REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZOZ(KDLON,KFLEV)
+c
+      REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+      REAL*8 ZBSUI(KDLON)                    ! Intermediate variable
+      REAL*8 ZCTS(KDLON,KFLEV)               ! Intermediate variable
+      REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+c
+      INTEGER ilim, i, k, kpl1
+C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         PRINT*, "LW clear-sky calling frequency: ", lw0pas
+         PRINT*, "LW cloudy-sky calling frequency: ", lwpas
+         PRINT*, "   In general, they should be 1"
+         appel1er=.FALSE.
+      ENDIF
+C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+      DO k = 1, KFLEV  ! convertir ozone de kg/kg en pa/pa
+      DO i = 1, KDLON
+         ZOZ(i,k) = POZON(i,k)*PDP(i,k) * 28.9644/47.9942
+      ENDDO
+      ENDDO
+      CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+     S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
+     S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
+     S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
+     S         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
+     .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
+     .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+c
+         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     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+     S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
+     S               PABCU)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+C           TEMPERATURE EFFECTS
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      REAL*8 RCO2
+      REAL*8 RCH4, RN2O, RCFC11, RCFC12
+      REAL*8 PAER(KDLON,KFLEV,5)
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PPSOL(KDLON)
+      REAL*8 POZ(KDLON,KFLEV)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PVIEW(KDLON)
+      REAL*8 PWV(KDLON,KFLEV)
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+C
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL*8 ZDUC(KDLON,3*KFLEV+1)
+      REAL*8 ZPHIO(KDLON)
+      REAL*8 ZPSC2(KDLON)
+      REAL*8 ZPSC3(KDLON)
+      REAL*8 ZPSH1(KDLON)
+      REAL*8 ZPSH2(KDLON)
+      REAL*8 ZPSH3(KDLON)
+      REAL*8 ZPSH4(KDLON)
+      REAL*8 ZPSH5(KDLON)
+      REAL*8 ZPSH6(KDLON)
+      REAL*8 ZPSIO(KDLON)
+      REAL*8 ZTCON(KDLON)
+      REAL*8 ZPHM6(KDLON)
+      REAL*8 ZPSM6(KDLON)
+      REAL*8 ZPHN6(KDLON)
+      REAL*8 ZPSN6(KDLON)
+      REAL*8 ZSSIG(KDLON,3*KFLEV+1)
+      REAL*8 ZTAVI(KDLON)
+      REAL*8 ZUAER(KDLON,Ninter)
+      REAL*8 ZXOZ(KDLON)
+      REAL*8 ZXWV(KDLON)
+C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL*8 zfppw, ztx, ztx2, zzably
+      REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL*8 zcac8, zcbc8
+      REAL*8 zalup, zdiff
+c
+      REAL*8 PVGCO2, PVGH2O, PVGO3
+C
+      REAL*8 R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+c
+c Used Data Block:
+c
+      REAL*8 TREF
+      SAVE TREF
+      REAL*8 RT1(2)
+      SAVE RT1
+      REAL*8 RAER(5,5)
+      SAVE RAER
+      REAL*8 AT(8,3), BT(8,3)
+      SAVE AT, BT
+      REAL*8 OCT(4)
+      SAVE OCT
+      DATA TREF /250.0/
+      DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
+      DATA RAER / .038520, .037196, .040532, .054934, .038520
+     1          , .12613 , .18313 , .10357 , .064106, .126130
+     2          , .012579, .013649, .018652, .025181, .012579
+     3          , .011890, .016142, .021105, .028908, .011890
+     4          , .013792, .026810, .052203, .066338, .013792 /
+      DATA (AT(1,IR),IR=1,3) /
+     S 0.298199E-02,-.394023E-03,0.319566E-04 /
+      DATA (BT(1,IR),IR=1,3) /
+     S-0.106432E-04,0.660324E-06,0.174356E-06 /
+      DATA (AT(2,IR),IR=1,3) /
+     S 0.143676E-01,0.366501E-02,-.160822E-02 /
+      DATA (BT(2,IR),IR=1,3) /
+     S-0.553979E-04,-.101701E-04,0.920868E-05 /
+      DATA (AT(3,IR),IR=1,3) /
+     S 0.197861E-01,0.315541E-02,-.174547E-02 /
+      DATA (BT(3,IR),IR=1,3) /
+     S-0.877012E-04,0.513302E-04,0.523138E-06 /
+      DATA (AT(4,IR),IR=1,3) /
+     S 0.289560E-01,-.208807E-02,-.121943E-02 /
+      DATA (BT(4,IR),IR=1,3) /
+     S-0.165960E-03,0.157704E-03,-.146427E-04 /
+      DATA (AT(5,IR),IR=1,3) /
+     S 0.103800E-01,0.436296E-02,-.161431E-02 /
+      DATA (BT(5,IR),IR=1,3) /
+     S -.276744E-04,-.327381E-04,0.127646E-04 /
+      DATA (AT(6,IR),IR=1,3) /
+     S 0.868859E-02,-.972752E-03,0.000000E-00 /
+      DATA (BT(6,IR),IR=1,3) /
+     S -.278412E-04,-.713940E-06,0.117469E-05 /
+      DATA (AT(7,IR),IR=1,3) /
+     S 0.250073E-03,0.455875E-03,0.109242E-03 /
+      DATA (BT(7,IR),IR=1,3) /
+     S 0.199846E-05,-.216313E-05,0.175991E-06 /
+      DATA (AT(8,IR),IR=1,3) /
+     S 0.307423E-01,0.110879E-02,-.322172E-03 /
+      DATA (BT(8,IR),IR=1,3) /
+     S-0.108482E-03,0.258096E-05,-.814575E-06 /
+c
+      DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
+C-----------------------------------------------------------------------
+c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+C
+C
+C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+C                ------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
+     S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+C                --------------------------------------------------
+C
+ 400  CONTINUE
+C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
+     S                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+C                --------------------------------------------------
+C
+ 500  CONTINUE
+C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+C
+C
+C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+C               --------------------------------------------------
+C
+ 510  CONTINUE
+C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
+     S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
+     S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
+     S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+C
+C
+C
+C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+C               --------------------------------------------------
+C
+ 520  CONTINUE
+C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+CMAF      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+CMAF      ZUP   = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
+      ZUP   = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
+     S                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
+     S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
+     S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
+     S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
+     S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
+     S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
+     S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
+     S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
+     S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+C
+      PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S               +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+      PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+      PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S               +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+      PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S               +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C
+      PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+      PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+ 523  CONTINUE
+ 524  CONTINUE
+C
+ 529  CONTINUE
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
+     S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C     PURPOSE.
+C     --------
+C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+C           SAVING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+C                                          MEMORY)
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER KLIM
+C
+      REAL*8 PDP(KDLON,KFLEV)
+      REAL*8 PDT0(KDLON)
+      REAL*8 PEMIS(KDLON)
+      REAL*8 PPMB(KDLON,KFLEV+1)
+      REAL*8 PTL(KDLON,KFLEV+1)
+      REAL*8 PTAVE(KDLON,KFLEV)
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1)
+C     
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL*8 PBINT(KDLON,KFLEV+1)
+      REAL*8 PBSUI(KDLON)
+      REAL*8 PCTS(KDLON,KFLEV)
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+C
+C-------------------------------------------------------------------------
+C
+C* LOCAL VARIABLES:
+      REAL*8 ZB(KDLON,Ninter,KFLEV+1)
+      REAL*8 ZBSUR(KDLON,Ninter)
+      REAL*8 ZBTOP(KDLON,Ninter)
+      REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL*8 ZGA(KDLON,8,2,KFLEV)
+      REAL*8 ZGB(KDLON,8,2,KFLEV)
+      REAL*8 ZGASUR(KDLON,8,2)
+      REAL*8 ZGBSUR(KDLON,8,2)
+      REAL*8 ZGATOP(KDLON,8,2)
+      REAL*8 ZGBTOP(KDLON,8,2)
+C
+      INTEGER nuaer, ntraer
+C     ------------------------------------------------------------------
+C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB(PDT0,PTAVE,PTL,
+     S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
+     S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+C     ------------------------------------------------------------------
+C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV(NUAER,NTRAER, KLIM
+     R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
+     R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+C     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
+     R               PBINT,PBSUIN,PCTS,PCNTRB,
+     S               PFLUX)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+C           RADIANCES
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+C PFLUC
+C     ==== OUTPUTS ===
+C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+C                     1  ==>  UPWARD   FLUX TOTAL
+C                     2  ==>  DOWNWARD FLUX TOTAL
+C
+C     METHOD.
+C     -------
+C
+C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+C     CLOUDS
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER klim
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL*8 PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+c
+      REAL*8 PCLDLD(KDLON,KFLEV)
+      REAL*8 PCLDLU(KDLON,KFLEV)
+      REAL*8 PEMIS(KDLON)
+C
+      REAL*8 PFLUX(KDLON,2,KFLEV+1)
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+C
+      REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
+     S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
+     S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
+C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL*8 zcfrac
+C     ------------------------------------------------------------------
+C
+C*         1.     INITIALIZATION
+C                 --------------
+C
+ 100  CONTINUE
+C
+      IMAXC = 0
+C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+C
+C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+C                 -------------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+CGM*******
+      IMAXC=KFLEV
+CGM*******
+C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+C                  ---------------------------------------
+C
+      IF (IMAXC.GT.0) THEN
+C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+C
+C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+C                  ------------------------------
+C
+ 200  CONTINUE
+C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+C
+C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+C                  ----------------------------------------------
+C
+ 210  CONTINUE
+C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+C
+C*         2.1.1   ABOVE THE CLOUD
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+C
+C*         2.1.2   BELOW THE CLOUD
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+C
+ 213     CONTINUE
+C
+C
+C*         2.2     CLOUD COVER MATRIX
+C                  ------------------
+C
+C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+C
+ 220  CONTINUE
+C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+C
+C
+C
+C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 240  CONTINUE
+C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+C
+C
+C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 250  CONTINUE
+C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+C
+C
+C
+C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+C                  ----------------------------------------------
+C
+ 300  CONTINUE
+C
+C*         3.1     DOWNWARD FLUXES
+C                  ---------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+C
+      DO 317 JK1 = KFLEV , 1 , -1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+C
+ 317  CONTINUE
+C
+C
+C
+C
+C*         3.2     UPWARD FLUX AT THE SURFACE
+C                  --------------------------
+C
+ 320  CONTINUE
+C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+C
+C
+C
+C*         3.3     UPWARD FLUXES
+C                  -------------
+C
+ 330  CONTINUE
+C
+      DO 337 JK1 = 2 , KFLEV+1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+C
+ 337  CONTINUE
+C
+C
+      END IF
+C
+C
+C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+C
+ 230  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+C
+      RETURN
+      END
+      SUBROUTINE LWB(PDT0,PTAVE,PTL
+     S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
+     S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES PLANCK FUNCTIONS
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+C     ==== OUTPUTS ===
+C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C
+C-----------------------------------------------------------------------
+C
+C ARGUMENTS:
+C
+      REAL*8 PDT0(KDLON)
+      REAL*8 PTAVE(KDLON,KFLEV)
+      REAL*8 PTL(KDLON,KFLEV+1)
+C
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+C-------------------------------------------------------------------------
+C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL*8 zdsto1, zdstox, zdst1, zdstx
+c
+C* Quelques parametres:
+      REAL*8 TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL*8 TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+C
+C* Used Data Block:
+      REAL*8 TINTP(11)
+      SAVE TINTP
+      REAL*8 GA(11,16,3), GB(11,16,3)
+      SAVE GA, GB
+      REAL*8 XP(6,6)
+      SAVE XP
+c
+      DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+     S             262.5, 275., 287.5, 300., 312.5 /
+C-----------------------------------------------------------------------
+C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+C
+C
+C
+C
+C-- R.D. -- G = - 0.2 SLA
+C
+C
+C----- INTERVAL = 1 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+      DATA (GB( 1, 1,IC),IC=1,3) /
+     S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+      DATA (GA( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+      DATA (GB( 1, 2,IC),IC=1,3) /
+     S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+      DATA (GB( 2, 1,IC),IC=1,3) /
+     S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+      DATA (GA( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+      DATA (GB( 2, 2,IC),IC=1,3) /
+     S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+      DATA (GB( 3, 1,IC),IC=1,3) /
+     S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+      DATA (GA( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+      DATA (GB( 3, 2,IC),IC=1,3) /
+     S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+      DATA (GB( 4, 1,IC),IC=1,3) /
+     S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+      DATA (GA( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+      DATA (GB( 4, 2,IC),IC=1,3) /
+     S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+      DATA (GB( 5, 1,IC),IC=1,3) /
+     S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+      DATA (GA( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+      DATA (GB( 5, 2,IC),IC=1,3) /
+     S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+      DATA (GB( 6, 1,IC),IC=1,3) /
+     S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+      DATA (GA( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+      DATA (GB( 6, 2,IC),IC=1,3) /
+     S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+      DATA (GB( 7, 1,IC),IC=1,3) /
+     S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+      DATA (GA( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+      DATA (GB( 7, 2,IC),IC=1,3) /
+     S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+      DATA (GB( 8, 1,IC),IC=1,3) /
+     S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+      DATA (GA( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+      DATA (GB( 8, 2,IC),IC=1,3) /
+     S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+      DATA (GB( 9, 1,IC),IC=1,3) /
+     S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+      DATA (GA( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+      DATA (GB( 9, 2,IC),IC=1,3) /
+     S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+      DATA (GB(10, 1,IC),IC=1,3) /
+     S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+      DATA (GA(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+      DATA (GB(10, 2,IC),IC=1,3) /
+     S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+      DATA (GB(11, 1,IC),IC=1,3) /
+     S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+      DATA (GA(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+      DATA (GB(11, 2,IC),IC=1,3) /
+     S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+C
+C
+C
+C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+C
+C
+C
+C
+C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+C
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+      DATA (GB( 1, 3,IC),IC=1,3) /
+     S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+      DATA (GA( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+      DATA (GB( 1, 4,IC),IC=1,3) /
+     S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+      DATA (GB( 2, 3,IC),IC=1,3) /
+     S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+      DATA (GA( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+      DATA (GB( 2, 4,IC),IC=1,3) /
+     S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+      DATA (GB( 3, 3,IC),IC=1,3) /
+     S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+      DATA (GA( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+      DATA (GB( 3, 4,IC),IC=1,3) /
+     S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+      DATA (GB( 4, 3,IC),IC=1,3) /
+     S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+      DATA (GA( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+      DATA (GB( 4, 4,IC),IC=1,3) /
+     S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+      DATA (GB( 5, 3,IC),IC=1,3) /
+     S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+      DATA (GA( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+      DATA (GB( 5, 4,IC),IC=1,3) /
+     S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+      DATA (GB( 6, 3,IC),IC=1,3) /
+     S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+      DATA (GA( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+      DATA (GB( 6, 4,IC),IC=1,3) /
+     S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+      DATA (GB( 7, 3,IC),IC=1,3) /
+     S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+      DATA (GA( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+      DATA (GB( 7, 4,IC),IC=1,3) /
+     S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+      DATA (GB( 8, 3,IC),IC=1,3) /
+     S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+      DATA (GA( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+      DATA (GB( 8, 4,IC),IC=1,3) /
+     S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+      DATA (GB( 9, 3,IC),IC=1,3) /
+     S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+      DATA (GA( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+      DATA (GB( 9, 4,IC),IC=1,3) /
+     S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+      DATA (GB(10, 3,IC),IC=1,3) /
+     S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+      DATA (GA(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+      DATA (GB(10, 4,IC),IC=1,3) /
+     S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+      DATA (GB(11, 3,IC),IC=1,3) /
+     S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+      DATA (GA(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+      DATA (GB(11, 4,IC),IC=1,3) /
+     S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+C
+C
+C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C
+C--- G = 3.875E-03 ---------------
+C
+C----- INTERVAL = 3 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+      DATA (GB( 1, 7,IC),IC=1,3) /
+     S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+      DATA (GA( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+      DATA (GB( 1, 8,IC),IC=1,3) /
+     S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+      DATA (GB( 2, 7,IC),IC=1,3) /
+     S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+      DATA (GA( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+      DATA (GB( 2, 8,IC),IC=1,3) /
+     S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+      DATA (GB( 3, 7,IC),IC=1,3) /
+     S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+      DATA (GA( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+      DATA (GB( 3, 8,IC),IC=1,3) /
+     S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+      DATA (GB( 4, 7,IC),IC=1,3) /
+     S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+      DATA (GA( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+      DATA (GB( 4, 8,IC),IC=1,3) /
+     S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+      DATA (GB( 5, 7,IC),IC=1,3) /
+     S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+      DATA (GA( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+      DATA (GB( 5, 8,IC),IC=1,3) /
+     S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+      DATA (GB( 6, 7,IC),IC=1,3) /
+     S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+      DATA (GA( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+      DATA (GB( 6, 8,IC),IC=1,3) /
+     S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+      DATA (GB( 7, 7,IC),IC=1,3) /
+     S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+      DATA (GA( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+      DATA (GB( 7, 8,IC),IC=1,3) /
+     S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+      DATA (GB( 8, 7,IC),IC=1,3) /
+     S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+      DATA (GA( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+      DATA (GB( 8, 8,IC),IC=1,3) /
+     S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+      DATA (GB( 9, 7,IC),IC=1,3) /
+     S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+      DATA (GA( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+      DATA (GB( 9, 8,IC),IC=1,3) /
+     S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+      DATA (GB(10, 7,IC),IC=1,3) /
+     S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+      DATA (GA(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+      DATA (GB(10, 8,IC),IC=1,3) /
+     S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+      DATA (GB(11, 7,IC),IC=1,3) /
+     S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+      DATA (GA(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+      DATA (GB(11, 8,IC),IC=1,3) /
+     S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+C
+C
+C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+C
+C-- G = 3.6E-03
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+      DATA (GB( 1, 9,IC),IC=1,3) /
+     S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+      DATA (GA( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+      DATA (GB( 1,10,IC),IC=1,3) /
+     S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+      DATA (GB( 2, 9,IC),IC=1,3) /
+     S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+      DATA (GA( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+      DATA (GB( 2,10,IC),IC=1,3) /
+     S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+      DATA (GB( 3, 9,IC),IC=1,3) /
+     S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+      DATA (GA( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+      DATA (GB( 3,10,IC),IC=1,3) /
+     S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+      DATA (GB( 4, 9,IC),IC=1,3) /
+     S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+      DATA (GA( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+      DATA (GB( 4,10,IC),IC=1,3) /
+     S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+      DATA (GB( 5, 9,IC),IC=1,3) /
+     S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+      DATA (GA( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+      DATA (GB( 5,10,IC),IC=1,3) /
+     S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+      DATA (GB( 6, 9,IC),IC=1,3) /
+     S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+      DATA (GA( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+      DATA (GB( 6,10,IC),IC=1,3) /
+     S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+      DATA (GB( 7, 9,IC),IC=1,3) /
+     S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+      DATA (GA( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+      DATA (GB( 7,10,IC),IC=1,3) /
+     S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+      DATA (GB( 8, 9,IC),IC=1,3) /
+     S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+      DATA (GA( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+      DATA (GB( 8,10,IC),IC=1,3) /
+     S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+      DATA (GB( 9, 9,IC),IC=1,3) /
+     S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+      DATA (GA( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+      DATA (GB( 9,10,IC),IC=1,3) /
+     S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+      DATA (GB(10, 9,IC),IC=1,3) /
+     S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+      DATA (GA(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+      DATA (GB(10,10,IC),IC=1,3) /
+     S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+      DATA (GA(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+      DATA (GB(11, 9,IC),IC=1,3) /
+     S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+      DATA (GA(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+      DATA (GB(11,10,IC),IC=1,3) /
+     S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+C
+C
+C
+C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+C
+C-- WATER VAPOR --- 350 - 500 CM-1
+C
+C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+C
+C----- INTERVAL = 5 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+      DATA (GB( 1, 5,IC),IC=1,3) /
+     S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+      DATA (GA( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+      DATA (GB( 1, 6,IC),IC=1,3) /
+     S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+      DATA (GB( 2, 5,IC),IC=1,3) /
+     S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+      DATA (GA( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+      DATA (GB( 2, 6,IC),IC=1,3) /
+     S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+      DATA (GB( 3, 5,IC),IC=1,3) /
+     S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+      DATA (GA( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+      DATA (GB( 3, 6,IC),IC=1,3) /
+     S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+      DATA (GB( 4, 5,IC),IC=1,3) /
+     S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+      DATA (GA( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+      DATA (GB( 4, 6,IC),IC=1,3) /
+     S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+      DATA (GB( 5, 5,IC),IC=1,3) /
+     S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+      DATA (GA( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+      DATA (GB( 5, 6,IC),IC=1,3) /
+     S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+      DATA (GB( 6, 5,IC),IC=1,3) /
+     S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+      DATA (GA( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+      DATA (GB( 6, 6,IC),IC=1,3) /
+     S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+      DATA (GB( 7, 5,IC),IC=1,3) /
+     S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+      DATA (GA( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+      DATA (GB( 7, 6,IC),IC=1,3) /
+     S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+      DATA (GB( 8, 5,IC),IC=1,3) /
+     S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+      DATA (GA( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+      DATA (GB( 8, 6,IC),IC=1,3) /
+     S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+      DATA (GB( 9, 5,IC),IC=1,3) /
+     S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+      DATA (GA( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+      DATA (GB( 9, 6,IC),IC=1,3) /
+     S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+      DATA (GB(10, 5,IC),IC=1,3) /
+     S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+      DATA (GA(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+      DATA (GB(10, 6,IC),IC=1,3) /
+     S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+      DATA (GB(11, 5,IC),IC=1,3) /
+     S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+      DATA (GA(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+      DATA (GB(11, 6,IC),IC=1,3) /
+     S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+C
+C
+C
+C
+C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+C--- G = 0.0
+C
+C
+C----- INTERVAL = 6 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+      DATA (GB( 1,11,IC),IC=1,3) /
+     S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+      DATA (GA( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+      DATA (GB( 1,12,IC),IC=1,3) /
+     S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+      DATA (GB( 2,11,IC),IC=1,3) /
+     S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+      DATA (GA( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+      DATA (GB( 2,12,IC),IC=1,3) /
+     S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+      DATA (GB( 3,11,IC),IC=1,3) /
+     S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+      DATA (GA( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+      DATA (GB( 3,12,IC),IC=1,3) /
+     S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+      DATA (GB( 4,11,IC),IC=1,3) /
+     S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+      DATA (GA( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+      DATA (GB( 4,12,IC),IC=1,3) /
+     S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+      DATA (GB( 5,11,IC),IC=1,3) /
+     S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+      DATA (GA( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+      DATA (GB( 5,12,IC),IC=1,3) /
+     S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+      DATA (GB( 6,11,IC),IC=1,3) /
+     S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+      DATA (GA( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+      DATA (GB( 6,12,IC),IC=1,3) /
+     S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+      DATA (GB( 7,11,IC),IC=1,3) /
+     S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+      DATA (GA( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+      DATA (GB( 7,12,IC),IC=1,3) /
+     S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+      DATA (GB( 8,11,IC),IC=1,3) /
+     S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+      DATA (GA( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+      DATA (GB( 8,12,IC),IC=1,3) /
+     S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+      DATA (GB( 9,11,IC),IC=1,3) /
+     S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+      DATA (GA( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+      DATA (GB( 9,12,IC),IC=1,3) /
+     S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+      DATA (GB(10,11,IC),IC=1,3) /
+     S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+      DATA (GA(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+      DATA (GB(10,12,IC),IC=1,3) /
+     S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+      DATA (GA(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+      DATA (GB(11,11,IC),IC=1,3) /
+     S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+      DATA (GA(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+      DATA (GB(11,12,IC),IC=1,3) /
+     S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C-- END WATER VAPOR
+C
+C
+C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+C
+C
+C
+C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+      DATA (GB( 1,13,IC),IC=1,3) /
+     S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+      DATA (GA( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+      DATA (GB( 1,14,IC),IC=1,3) /
+     S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+      DATA (GB( 2,13,IC),IC=1,3) /
+     S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+      DATA (GA( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+      DATA (GB( 2,14,IC),IC=1,3) /
+     S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+      DATA (GB( 3,13,IC),IC=1,3) /
+     S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+      DATA (GA( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+      DATA (GB( 3,14,IC),IC=1,3) /
+     S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+      DATA (GB( 4,13,IC),IC=1,3) /
+     S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+      DATA (GA( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+      DATA (GB( 4,14,IC),IC=1,3) /
+     S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+      DATA (GB( 5,13,IC),IC=1,3) /
+     S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+      DATA (GA( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+      DATA (GB( 5,14,IC),IC=1,3) /
+     S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+      DATA (GB( 6,13,IC),IC=1,3) /
+     S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+      DATA (GA( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+      DATA (GB( 6,14,IC),IC=1,3) /
+     S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+      DATA (GB( 7,13,IC),IC=1,3) /
+     S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+      DATA (GA( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+      DATA (GB( 7,14,IC),IC=1,3) /
+     S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+      DATA (GB( 8,13,IC),IC=1,3) /
+     S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+      DATA (GA( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+      DATA (GB( 8,14,IC),IC=1,3) /
+     S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+      DATA (GB( 9,13,IC),IC=1,3) /
+     S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+      DATA (GA( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+      DATA (GB( 9,14,IC),IC=1,3) /
+     S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+      DATA (GB(10,13,IC),IC=1,3) /
+     S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+      DATA (GA(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+      DATA (GB(10,14,IC),IC=1,3) /
+     S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+      DATA (GA(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+      DATA (GB(11,13,IC),IC=1,3) /
+     S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+      DATA (GA(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+      DATA (GB(11,14,IC),IC=1,3) /
+     S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C-- G = 0.0
+C
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+      DATA (GB( 1,15,IC),IC=1,3) /
+     S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+      DATA (GA( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+      DATA (GB( 1,16,IC),IC=1,3) /
+     S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+      DATA (GB( 2,15,IC),IC=1,3) /
+     S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+      DATA (GA( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+      DATA (GB( 2,16,IC),IC=1,3) /
+     S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+      DATA (GB( 3,15,IC),IC=1,3) /
+     S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+      DATA (GA( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+      DATA (GB( 3,16,IC),IC=1,3) /
+     S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+      DATA (GB( 4,15,IC),IC=1,3) /
+     S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+      DATA (GA( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+      DATA (GB( 4,16,IC),IC=1,3) /
+     S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+      DATA (GB( 5,15,IC),IC=1,3) /
+     S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+      DATA (GA( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+      DATA (GB( 5,16,IC),IC=1,3) /
+     S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+      DATA (GB( 6,15,IC),IC=1,3) /
+     S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+      DATA (GA( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+      DATA (GB( 6,16,IC),IC=1,3) /
+     S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+      DATA (GB( 7,15,IC),IC=1,3) /
+     S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+      DATA (GA( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+      DATA (GB( 7,16,IC),IC=1,3) /
+     S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+      DATA (GB( 8,15,IC),IC=1,3) /
+     S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+      DATA (GA( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+      DATA (GB( 8,16,IC),IC=1,3) /
+     S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+      DATA (GB( 9,15,IC),IC=1,3) /
+     S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+      DATA (GA( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+      DATA (GB( 9,16,IC),IC=1,3) /
+     S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+      DATA (GB(10,15,IC),IC=1,3) /
+     S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+      DATA (GA(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+      DATA (GB(10,16,IC),IC=1,3) /
+     S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+      DATA (GA(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+      DATA (GB(11,15,IC),IC=1,3) /
+     S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+      DATA (GA(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+      DATA (GB(11,16,IC),IC=1,3) /
+     S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+
+C     ------------------------------------------------------------------
+      DATA (( XP(  J,K),J=1,6),       K=1,6) /
+     S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+     S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+     S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+     S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+     S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+     S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+     S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+     S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+     S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+     S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+     S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+     S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+C
+C
+C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+C                  ------------------------------
+C
+ 100  CONTINUE
+C
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+C
+      DO 141 JNU=1,Ninter
+C
+C
+C*         1.1   LEVELS FROM SURFACE TO KFLEV
+C                ----------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C
+C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+C                ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+C
+C
+C*         1.3   GRADIENTS IN SUB-LAYERS
+C                -----------------------
+C
+ 130  CONTINUE
+C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+C
+ 141  CONTINUE
+C
+C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+C                ---------------------------------------------
+C
+ 200  CONTINUE
+C
+C
+ 210  CONTINUE
+C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+C
+ 220  CONTINUE
+C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWV(KUAER,KTRAER, KLIM
+     R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+C           FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+C                      -  THE DISTANT LAYERS
+C                      -  THE BOUNDARY TERMS
+C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+C-----------------------------------------------------------------------
+C LOCAL VARIABLES:
+      REAL*8 ZADJD(KDLON,KFLEV+1)
+      REAL*8 ZADJU(KDLON,KFLEV+1)
+      REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
+      REAL*8 ZDISD(KDLON,KFLEV+1)
+      REAL*8 ZDISU(KDLON,KFLEV+1)
+C
+      INTEGER jk, jl
+C-----------------------------------------------------------------------
+C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C* CONTRIBUTION FROM ADJACENT LAYERS
+C
+      CALL LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+C* CONTRIBUTION FROM DISTANT LAYERS
+C
+      CALL LWVD(KUAER,KTRAER
+     R  , PABCU,ZDBDT,PGA,PGB
+     S  , PCNTRB,ZDISD,ZDISU)
+C
+C* EXCHANGE WITH THE BOUNDARIES
+C
+      CALL LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
+     R  , ZDISD,ZDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWVB(KUAER,KTRAER, KLIM
+     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
+     R  , PDISD,PDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+C           INTEGRATION
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+C     ATMOSPHERE
+C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZBGND(KDLON)
+      REAL*8 ZFD(KDLON)
+      REAL*8  ZFN10(KDLON)
+      REAL*8 ZFU(KDLON)
+      REAL*8  ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8  ZUU(KDLON,NUA) 
+      REAL*8 ZCNSOL(KDLON)
+      REAL*8 ZCNTOP(KDLON)
+C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL*8 zctstr
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+C                  -----------------------------------
+C
+ 230  CONTINUE
+C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+C
+C
+      CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+C
+ 235  CONTINUE
+C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)
+     1   + PBTOP(JL,2)
+     2   + PBTOP(JL,3)
+     3   + PBTOP(JL,4)
+     4   + PBTOP(JL,5)
+     5   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+C
+C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+C                  ---------------------------------------
+C
+ 240  CONTINUE
+C
+C
+C*         2.4.1   INITIALIZATION
+C                  --------------
+C
+ 2410 CONTINUE
+C
+      JLIM = KFLEV
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+C
+C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+C                  -----------------------------
+C
+ 2420   CONTINUE
+C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+C
+C
+        CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =
+     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
+     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
+     1       - ZTT (JL,1)           *ZTT (JL,10))
+     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
+     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
+     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
+     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
+     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
+     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
+     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
+     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
+     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
+     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
+     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
+     5       - ZTT (JL,3)           *ZTT (JL,14))
+     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
+     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
+     6       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+C
+C
+C*         2.5     EXCHANGE WITH LOWER LIMIT
+C                  -------------------------
+C
+ 250  CONTINUE
+C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
+     S               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)
+     1 +PBSUR(JL,2)
+     2 +PBSUR(JL,3)
+     3 +PBSUR(JL,4)
+     4 +PBSUR(JL,5)
+     5 +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+C
+C
+      CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+C
+C
+ 257  CONTINUE
+C
+C
+C
+C*         2.7     CLEAR-SKY FLUXES
+C                  ----------------
+C
+ 270  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWVD(KUAER,KTRAER
+     S  , PABCU,PDBDT
+     R  , PGA,PGB
+     S  , PCNTRB,PDISD,PDISU)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL*8 PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL*8 PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL*8 zww, zdzxdg, zdzxmg
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+C                  ---------------------------------
+C
+ 220  CONTINUE
+C
+C
+C*         2.2.1   DISTANT AND ABOVE LAYERS
+C                  ------------------------
+C
+ 2210 CONTINUE
+C
+C
+C
+C*         2.2.2   FIRST UPPER LEVEL
+C                  -----------------
+C
+ 2220 CONTINUE
+C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+C
+      CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
+     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+C
+C
+C
+C*         2.2.3   HIGHER UP
+C                  ---------
+C
+ 2230 CONTINUE
+C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+C
+C
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C
+C*         2.2.4   DISTANT AND BELOW LAYERS
+C                  ------------------------
+C
+ 2240 CONTINUE
+C
+C
+C
+C*         2.2.5   FIRST LOWER LEVEL
+C                  -----------------
+C
+ 2250 CONTINUE
+C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+C
+C
+      CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
+     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+C
+C
+C
+C*         2.2.6   DOWN BELOW
+C                  ----------
+C
+ 2260 CONTINUE
+C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+C
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+C
+C
+ 227  CONTINUE
+ 228  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWVN(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , PADJD,PADJU,PCNTRB,PDBDT)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+C
+C* LOCAL ARRAYS:
+C
+      REAL*8 ZGLAYD(KDLON)
+      REAL*8 ZGLAYU(KDLON)
+      REAL*8 ZTT(KDLON,NTRA)
+      REAL*8 ZTT1(KDLON,NTRA)
+      REAL*8 ZTT2(KDLON,NTRA)
+      REAL*8 ZUU(KDLON,NUA)
+C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL*8 zwtr
+c
+C* Data Block:
+c
+      REAL*8 WG1(2)
+      SAVE WG1
+      DATA (WG1(jk),jk=1,2) /1.0, 1.0/
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+C
+C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+C                  ---------------------------------
+C
+ 210  CONTINUE
+C
+      DO 215 JK = 1 , KFLEV
+C
+C*         2.1.1   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+C
+C*         2.1.2   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+C
+C
+      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+C
+ 213  CONTINUE
+C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+C
+ 215  CONTINUE
+C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+C
+      RETURN
+C
+      END
+      SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PUU(KDLON,NUA)
+      REAL*8 PTT(KDLON,NTRA)
+      REAL*8 PGA(KDLON,8,2)
+      REAL*8 PGB(KDLON,8,2)
+C
+C* LOCAL VARIABLES:
+C
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL*8 zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL*8 zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+c     NEXOTIC=1
+c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
+      IMPLICIT none
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.h"
+#include "raddimlw.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL*8 O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL*8 RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER ja, jl
+      REAL*8 zz, zxd, zxn
+      REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
+      REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
+      REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL*8 zxch4, zych4, zsqh41, zodh41
+      REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL*8 zuu11, zuu12
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
+     S         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radopt.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radopt.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/radopt.h	(revision 428)
@@ -0,0 +1,6 @@
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/read_pstoke.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/read_pstoke.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/read_pstoke.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/read_pstoke0.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/read_pstoke0.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/read_pstoke0.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/regdim.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/regdim.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/regdim.h	(revision 428)
@@ -0,0 +1,13 @@
+      INTEGER i1_deb, i1_fin
+      INTEGER i2_deb, i2_fin
+ccc      PARAMETER (i1_deb=21, i1_fin=40)
+ccc      PARAMETER (i2_deb=41, i2_fin=44)
+cccc      PARAMETER (i1_deb=47, i1_fin=77)
+cccc      PARAMETER (i2_deb=78, i2_fin=79)
+      PARAMETER (i1_deb=16, i1_fin=30)
+      PARAMETER (i2_deb=31, i2_fin=33)
+c
+      INTEGER j_deb, j_fin
+ccc      PARAMETER (j_deb=29, j_fin=61)
+cccc      PARAMETER (j_deb=21, j_fin=51)
+      PARAMETER (j_deb=18, j_fin=39)
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenc.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenc.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenc.F90	(revision 428)
@@ -0,0 +1,81 @@
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, rugos, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.inc
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+#include "YOMCST.inc"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL coefcdrag (klon, knon, nsrf, zxli, &
+                    speed, temp, q_zref, gref, &
+                    psol, ts, qsurf, rugos, &
+                    okri, ri1, &
+                    cdram, cdrah, cdran, zri1, &
+                    pref)
+!
+      DO i = 1, knon
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenp.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenp.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/screenp.F90	(revision 428)
@@ -0,0 +1,105 @@
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.inc
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/soil.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/soil.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/soil.F	(revision 428)
@@ -0,0 +1,250 @@
+      SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, ptsoil,
+     s          pcapcal, pfluxgrd)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  Frederic Hourdin     30/01/92
+c   -------
+c
+c   objet:  computation of : the soil temperature evolution
+c   ------                   the surfacic heat capacity "Capcal"
+c                            the surface conduction flux pcapcal
+c
+c
+c   Method: implicit time integration
+c   -------
+c   Consecutive ground temperatures are related by:
+c           T(k+1) = C(k) + D(k)*T(k)  (1)
+c   the coefficients C and D are computed at the t-dt time-step.
+c   Routine structure:
+c   1)new temperatures are computed  using (1)
+c   2)C and D coefficients are computed from the new temperature
+c     profile for the t+dt time-step
+c   3)the coefficients A and B are computed where the diffusive
+c     fluxes at the t+dt time-step is given by
+c            Fdiff = A + B Ts(t+dt)
+c     or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+c            with F0 = A + B (Ts(t))
+c                 Capcal = B*dt
+c           
+c   Interface:
+c   ----------
+c
+c   Arguments:
+c   ----------
+c   ptimestep            physical timestep (s)
+c   indice               sub-surface index
+c   snow(klon,nbsrf)     snow
+c   ptsrf(klon)          surface temperature at time-step t (K)
+c   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+c   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+c   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+c   
+c=======================================================================
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "dimphy.h"
+#include "dimsoil.h"
+#include "indicesol.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      REAL ptimestep
+      INTEGER indice, knon
+      REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
+      REAL pcapcal(klon),pfluxgrd(klon)
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+c$$$      REAL zdz2(nsoilmx),z1(klon)
+      REAL zdz2(nsoilmx),z1(klon,nbsrf)
+      REAL min_period,dalph_soil
+      REAL ztherm_i(klon)
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(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, 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./
+
+c-----------------------------------------------------------------------
+c   Depthts:
+c   --------
+
+      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 
+c   ou le point de mer devienne point de glace au pas suivant
+c   on corrige si on a un point de terre avec ou sans glace
+c
+      IF (indice.EQ.is_sic) THEN
+         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, 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, 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, knon
+            ztherm_i(ig)   = iice
+         ENDDO
+      ELSE
+         PRINT*, "valeur d indice non prevue", indice
+         CALL abort
+      ENDIF
+
+
+c$$$      IF (firstcall) THEN
+      IF (firstsurf(indice)) THEN 
+
+c-----------------------------------------------------------------------
+c   ground levels 
+c   grnd=z/l where l is the skin depth of the diurnal cycle:
+c   --------------------------------------------------------
+
+         min_period=1800. ! en secondes
+         dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+
+         OPEN(99,file='soil.def',status='old',form='formatted',err=9999)
+         READ(99,*) min_period
+         READ(99,*) dalph_soil
+         PRINT*,'Discretization for the soil model'
+         PRINT*,'First level e-folding depth',min_period,
+     s   '   dalph',dalph_soil
+         CLOSE(99)
+9999     CONTINUE
+
+c   la premiere couche represente un dixieme de cycle diurne
+         fz1=sqrt(min_period/3.14)
+
+         DO jk=1,nsoilmx
+            rk1=jk
+            rk2=jk-1
+            dz2(jk)=fz(rk1)-fz(rk2)
+         ENDDO
+         DO jk=1,nsoilmx-1
+            rk1=jk+.5
+            rk2=jk-.5
+            dz1(jk)=1./(fz(rk1)-fz(rk2))
+         ENDDO
+         lambda=fz(.5)*dz1(1)
+         PRINT*,'full layers, intermediate layers (seconds)'
+         DO jk=1,nsoilmx
+            rk=jk
+            rk1=jk+.5
+            rk2=jk-.5
+            PRINT *,'fz=',
+     .               fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+         ENDDO
+C PB
+         firstsurf(indice) = .FALSE. 
+c$$$         firstcall =.false.
+
+c   Initialisations:
+c   ----------------
+
+      ELSE   !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the soil temperatures using the Cgrd and Dgrd
+c  coefficient computed at the previous time-step:
+c  -----------------------------------------------
+
+c    surface temperature
+         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,knon
+               ptsoil(ig,jk+1)=zc(ig,jk,indice)+zd(ig,jk,indice)
+     $            *ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+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,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,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
+
+c-----------------------------------------------------------------------
+c   computation of the surface diffusive flux from ground and
+c   calorific capacity of the ground:
+c   ---------------------------------
+
+      DO ig=1,knon
+         pfluxgrd(ig)=ztherm_i(ig)*dz1(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,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
+
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/stdlevvar.F90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/stdlevvar.F90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/stdlevvar.F90	(revision 428)
@@ -0,0 +1,237 @@
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, rugos, psol, pat1, &
+                           t_2m, q_2m, u_10m) 
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indicesol.inc
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, u_10m
+!-------------------------------------------------------------------------
+#include "YOMCST.inc"
+!IM PLUS
+#include "YOETHF.inc"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+      INTEGER, parameter :: niter=6, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: ustar, testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+      REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL coefcdrag(klon, knon, nsrf, zxli, &
+                     speed, t1, q1, z1, psol, &
+                     ts1, qsurf, rugos, okri, ri1,  &         
+                     cdram, cdrah, cdran, zri1, pref)            
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+                  (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+                   ts1, qsurf, rugos, lmon, &
+                   ustar, testar, qstar, zref, &
+                   delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+                     u_zref, temp, q_zref, zref, &
+                     ts1, qsurf, rugos, psol, &           
+                     ustar, testar, qstar, okri, ri1, &
+                     pref, delu, delte, delq) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+          IF(temp(i).GT.350.) THEN
+            WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+          ENDIF
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_p(i) = te_zref(i)
+          q_zref_p(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+        DO i = 1, knon
+          conv_te(i) = (te_zref(i) - te_zref_p(i))/te_zref_p(i)
+          conv_q(i) = (q_zref(i) - q_zref_p(i))/q_zref_p(i)
+          IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+            PRINT*,'DIV','i=',i,te_zref_p(i),te_zref(i),conv_te(i), &
+            q_zref_p(i),q_zref(i),conv_q(i)
+          ENDIF
+        ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+        IF(zri1(i).LT.0.) THEN
+          IF(nsrf.EQ.1) THEN
+            ok_pred(i)=1.
+            ok_corr(i)=0.
+          ELSE
+            ok_pred(i)=0.
+            ok_corr(i)=1.
+          ENDIF
+        ELSE
+          ok_pred(i)=0.
+          ok_corr(i)=1.
+        ENDIF
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+                   ts1, qsurf, rugos, lmon, &
+                   ustar, testar, qstar, zref, &
+                   delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+                     u_zref, temp, q_zref, zref, &
+                     ts1, qsurf, rugos, psol, &
+                     ustar, testar, qstar, okri, ri1, &
+                     pref, delu, delte, delq)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/suphec.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/suphec.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/suphec.F	(revision 428)
@@ -0,0 +1,187 @@
+      SUBROUTINE suphec
+C
+#include "YOMCST.h"
+#include "YOETHF.h"
+C      -----------------------------------------------------------------
+C
+C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+C              -----------------------------
+C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')
+     S RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')
+     S RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')
+     S RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')
+     S RNAVO
+C
+C     ----------------------------------------------------------------
+C
+C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+C              ------------------------------
+C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+c
+c exp1      R_ecc = 0.05
+c exp1      R_peri = 102.04
+c exp1      R_incl = 22.5
+c exp1      print*, 'Parametres orbitaux modifies'
+c ref      R_ecc = 0.016724
+c ref      R_peri = 102.04
+c ref      R_incl = 23.5
+      R_ecc = 0.016724
+      R_peri = 102.04
+      R_incl = 23.5
+c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')
+     S                  ROMEGA
+      write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+      write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+      write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+C
+C     ------------------------------------------------------------------
+C
+C*       3.    DEFINE GEOIDE.
+C              --------------
+C
+      RG=9.80665
+      RA=6371229.
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
+     S      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+C
+C     -----------------------------------------------------------------
+C
+C*       4.    DEFINE RADIATION CONSTANTS.
+C              ---------------------------
+C
+c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+      RI0=1370.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
+     S )')  RSIGMA
+      WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+     S      RI0
+C
+C     -----------------------------------------------------------------
+C
+C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+C              ------------------------------------------
+C
+      R=RNAVO*RKBOL
+      RMD=28.9644
+      RMV=18.0153
+      RD=1000.*R/RMD
+      RV=1000.*R/RMV
+      RCPD=3.5*RD
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+C
+C     ----------------------------------------------------------------
+C
+C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+C              ---------------------------------------------
+C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+C
+C     ----------------------------------------------------------------
+C
+C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+C              --------------------------------------------
+C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+C
+C     ----------------------------------------------------------------
+C
+C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+C              ----------------------------------------------------
+C
+      RTT=273.16
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+C
+C     ----------------------------------------------------------------
+C
+C*       9.    SATURATED VAPOUR PRESSURE.
+C              --------------------------
+C
+      RESTT=611.14
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+C
+C     ------------------------------------------------------------------
+c
+c calculer les constantes pour les fonctions thermodynamiques
+c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+C
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/tilft43.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/tilft43.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/tilft43.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/tlift.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/tlift.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/tlift.F	(revision 428)
@@ -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/IPSL-CM4_v1x1/libf/phylmd/transp.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/transp.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/transp.F	(revision 428)
@@ -0,0 +1,44 @@
+      SUBROUTINE transp (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/wrgradsfi.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/wrgradsfi.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/wrgradsfi.F	(revision 428)
@@ -0,0 +1,29 @@
+      subroutine wrgradsfi(if,nl,fieldfi,name,titlevar)
+      implicit none
+
+c   Declarations
+
+#include "dimensions.h"
+#include "dimphy.h"
+
+c   arguments
+      integer if,nl
+      real fieldfi(klon,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+c   local
+
+      integer lm,l,lnblnk
+
+
+
+c     print*,'Transformation pour ',name
+      call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+c     print*,'Transformation OK '
+      call wrgrads(if,nl,fielddyn,name,titlevar)
+c     print*,'Ecriture ok'
+
+      return
+      end
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histday.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histday.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histday.h	(revision 428)
@@ -0,0 +1,406 @@
+      IF (ok_journe) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         zsto = dtime
+         zout = dtime * FLOAT(ecrit_day)
+         itau_w = itau_phy + itap
+
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+       CALL histwrite(nid_day,"phis",itau_w,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",itau_w,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",itau_w,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",itau_w,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, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"tlic",itau_w,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, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"toce",itau_w,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, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"tsic",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c     call writephy(fid_day,prof2d_av,'tsic',ftsol(1 : klon, is_sic),
+c    .              'Surface Temperature','K')
+C
+cccIM
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite(nid_day,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite(nid_day,"t2m_min",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zt2m,zx_tmp_2d)
+      CALL histwrite(nid_day,"t2m_max",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"t2mter",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"t2mter_min",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"t2mter_max",itau_w,zx_tmp_2d,
+     .               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_lic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"t2mlic",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_oce)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"t2moce",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, is_sic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"t2msic",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zq2m,zx_tmp_2d)
+      CALL histwrite(nid_day,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zu10m,zx_tmp_2d)
+      CALL histwrite(nid_day,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zv10m,zx_tmp_2d)
+      CALL histwrite(nid_day,"v10m",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"u10mter",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_ter)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"v10mter",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_lic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"u10mlic",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_lic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"v10mlic",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_oce)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"u10moce",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_oce)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"v10moce",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, is_sic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"u10msic",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+C
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, is_sic)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day,"v10msic",itau_w,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,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"psol",itau_w,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))
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"precip",itau_w,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",itau_w,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_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c     call writephy(fid_day,prof2d_av,'snow_mass',zxsnow,
+c    .              'Snow cover','mm')
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_day,"evap",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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
+CXXX
+        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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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
+cXXX      DO i = 1, klon
+cXXX         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+cXXX      ENDDO
+cXXX      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+cXXX      CALL histwrite(nid_day,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldl",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c     call writephy(fid_day,prof3d_av,'pres',pplay,
+c    .              'Air pressure','Pa')
+cccIM
+      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, klevp1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day, "SWupTOA",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day, "SWupSFC",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, klevp1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day, "SWdnTOA",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day, "SWdnSFC",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      if (ok_sync) then
+c       call writephy_sync(fid_day)
+        call histsync(nid_day)
+      endif
+      ENDIF
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histhf.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histhf.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histhf.h	(revision 428)
@@ -0,0 +1,58 @@
+      if (ok_hf) then
+
+c   Comprendre comment marche el i=nint(zout/zsto)
+c
+      print*,'ACRITURE HF !!! ACRITURE HF !!! ACRITURE HF !!! '
+      ndex2d = 0
+      ndex3d = 0
+c
+c
+c     i = NINT(zout/zsto)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+c     CALL histwrite(nid_hf,"phis",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c     i = NINT(zout/zsto)
+c     CALL gr_fi_ecrit(1,klon,iim,jjmp1,paire,zx_tmp_2d)
+c     CALL histwrite(nid_hf,"aire",i,zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_hf,"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,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_hf,"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_hf,"rain",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, u850,zx_tmp_2d)
+      CALL histwrite(nid_hf,"u850",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, v850,zx_tmp_2d)
+      CALL histwrite(nid_hf,"v850",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, u500,zx_tmp_2d)
+      CALL histwrite(nid_hf,"u500",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, v500,zx_tmp_2d)
+      CALL histwrite(nid_hf,"v500",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, u200,zx_tmp_2d)
+      CALL histwrite(nid_hf,"u200",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, v200,zx_tmp_2d)
+      CALL histwrite(nid_hf,"v200",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, phi500,zx_tmp_2d)
+      CALL histwrite(nid_hf,"phi500",itap,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      if (ok_sync) then
+        call histsync(nid_hf)
+      endif
+
+      endif
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histins.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histins.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histins.h	(revision 428)
@@ -0,0 +1,198 @@
+      IF (ok_instan) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         zsto = dtime * ecrit_ins
+         zout = dtime * ecrit_ins
+         itau_w = itau_phy + itap
+
+         i = NINT(zout/zsto)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite(nid_ins,"phis",itau_w,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",itau_w,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,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"psol",itau_w,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,"precip",itau_w,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",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_ins,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+cccIM
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m, zx_tmp_2d)
+      CALL histwrite(nid_ins,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m, zx_tmp_2d)
+      CALL histwrite(nid_ins,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m, zx_tmp_2d)
+      CALL histwrite(nid_ins,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m, zx_tmp_2d)
+      CALL histwrite(nid_ins,"v10m",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite(nid_ins,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite(nid_ins,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_ins,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite(nid_ins,"solldown",itau_w,zx_tmp_2d,iim*jjmp1,
+     .                ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite(nid_ins,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+      CALL histwrite(nid_ins,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite(nid_ins,"fder",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+
+      DO nsrf = 1, nbsrf
+CXXX
+        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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+      CALL histwrite(nid_ins,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxrugs,zx_tmp_2d)
+      CALL histwrite(nid_ins,"rugs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c Champs 3D:
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_ins,"temp",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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_ins,"dtvdf",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+
+c
+      if (ok_sync) then
+        call histsync(nid_ins)
+      endif
+      ENDIF
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histmth.h
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histmth.h	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/write_histmth.h	(revision 428)
@@ -0,0 +1,450 @@
+      IF (ok_mensuel) THEN
+c
+      ndex2d = 0
+      ndex3d = 0
+c
+c Champs 2D:
+c
+         zsto = dtime
+         zout = dtime * ecrit_mth
+         itau_w = itau_phy + itap
+
+      i = NINT(zout/zsto)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,pphis,zx_tmp_2d)
+      CALL histwrite(nid_mth,"phis",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tsol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+cccIM
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zt2m,zx_tmp_2d)
+      CALL histwrite(nid_mth,"t2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zq2m,zx_tmp_2d)
+      CALL histwrite(nid_mth,"q2m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zu10m,zx_tmp_2d)
+      CALL histwrite(nid_mth,"u10m",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+C
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zv10m,zx_tmp_2d)
+      CALL histwrite(nid_mth,"v10m",itau_w,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,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"psol",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxqsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"qsol",itau_w,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_mth,"precip",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zxsnow,zx_tmp_2d)
+      CALL histwrite(nid_mth,"snow_mass",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, evap,zx_tmp_2d)
+      CALL histwrite(nid_mth,"evap",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollwdown,zx_tmp_2d)
+      CALL histwrite(nid_mth,"solldown",itau_w,zx_tmp_2d,iim*jjmp1,
+     .               ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, topsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, toplw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, solsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sollw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll0",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, bils,zx_tmp_2d)
+      CALL histwrite(nid_mth,"bils",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, sens,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sens",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, fder,zx_tmp_2d)
+      CALL histwrite(nid_mth,"fder",itau_w,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",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      DO nsrf = 1, nbsrf
+CYYY
+        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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w,
+     $      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),itau_w
+     $    ,zx_tmp_2d,iim*jjmp1,ndex2d)
+
+      END DO  
+cXXX      DO i = 1, klon
+cXXX         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+cXXX      ENDDO
+cXXX      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+cXXX      CALL histwrite(nid_mth,"sicf",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"albs",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, albsollw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"albslw",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cdragh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldl",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldm",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldh",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldt,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldt",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cldq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ue,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ue",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, ve,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ve",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, uq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"uq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, vq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"vq",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+cKE43
+      IF (iflag_con .GE. 3) THEN ! sb
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, cape,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cape",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1,pbase,zx_tmp_2d)
+      CALL histwrite(nid_mth,"pbase",itau_w,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",itau_w,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",itau_w,zx_tmp_2d,iim*jjmp1,ndex2d)
+c
+c
+      ENDIF
+c34EK
+c
+c Champs 3D:
+C
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"temp",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, clwcon0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"clwcon",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, zpt_conv, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ptconv",itau_w,zx_tmp_3d,
+     .                                   iim*(jjmp1)*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, ratqs, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ratqs",itau_w,zx_tmp_3d,
+     .                                   iim*(jjmp1)*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ajs, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtajs",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_t_ec, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtec",itau_w,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",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, d_u_lif, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dulif",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+      ENDIF
+C
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, wo, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ozone",itau_w,zx_tmp_3d,
+     .                                   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,jjmp1, qx(1,1,iq+2), zx_tmp_3d)
+         WRITE(str2,'(i2.2)') iq
+         CALL histwrite(nid_mth,"trac"//str2,itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+      ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ENDIF
+      ENDDO
+      ENDIF
+cKE43
+      IF (iflag_con.GE.3) THEN ! (sb)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjmp1, upwd, zx_tmp_3d)
+      CALL histwrite(nid_mth,"upwd",itau_w,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",itau_w,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",itau_w,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",itau_w,zx_tmp_3d,
+     .                                   iim*jjmp1*klev,ndex3d)
+c
+cccIM
+      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, klevp1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth, "SWupTOA",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSUP( 1 : klon, 1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth, "SWupSFC",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, klevp1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth, "SWdnTOA",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      zx_tmp_fi2d(1 : klon) = ZFSDN( 1 : klon, 1)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth, "SWdnSFC",itau_w,zx_tmp_2d,
+     .                               iim*jjmp1,ndex2d)
+c
+      
+      ENDIF
+
+      if (ok_sync) then
+        call histsync(nid_mth)
+      endif
+      ENDIF
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/zilch.F
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/zilch.F	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/libf/phylmd/zilch.F	(revision 428)
@@ -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
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources	(revision 428)
@@ -0,0 +1,230 @@
+libf/bibio/initdynav.F
+libf/bibio/lnblnk.F
+libf/bibio/writedynav.F
+libf/bibio/inithist.F
+libf/bibio/writehist.F
+libf/dyn3d/add_tend.F
+libf/dyn3d/add_vec.F
+libf/dyn3d/addfi.F
+libf/dyn3d/addit.F
+libf/dyn3d/adv_h2o.F
+libf/dyn3d/adv_hor.F
+libf/dyn3d/advect.F
+libf/dyn3d/advection.F
+libf/dyn3d/amont.F
+libf/dyn3d/amont_qsat.F
+libf/dyn3d/angtot.h
+libf/dyn3d/angumom.F
+libf/dyn3d/bernoui.F
+libf/dyn3d/bin2grads.F
+libf/dyn3d/bin2grads56.F
+libf/dyn3d/cal_br.F
+libf/dyn3d/cal_br_st.F
+libf/dyn3d/calc_uvtq.F
+libf/dyn3d/caldyn.F
+libf/dyn3d/caldyn0.F
+libf/dyn3d/calfis.F
+libf/dyn3d/clesph0.h
+libf/dyn3d/comav.h
+libf/dyn3d/comconst.h
+libf/dyn3d/comdiss.h
+libf/dyn3d/comdissip.h
+libf/dyn3d/comdissipn.h
+libf/dyn3d/comdissnew.h
+libf/dyn3d/comgeom.h
+libf/dyn3d/comgeom2.h
+libf/dyn3d/comvert.h
+libf/dyn3d/control.h
+libf/dyn3d/convflu.F
+libf/dyn3d/convmas.F
+libf/dyn3d/coordij.F
+libf/dyn3d/covcont.F
+libf/dyn3d/covnat.F
+libf/dyn3d/cray.F
+libf/dyn3d/defrun.F
+libf/dyn3d/defrun_new.F
+libf/dyn3d/description.h
+libf/dyn3d/dh1.F
+libf/dyn3d/dissip.F
+libf/dyn3d/disvert.F
+libf/dyn3d/disvert0.F
+libf/dyn3d/diverg.F
+libf/dyn3d/diverg_gam.F
+libf/dyn3d/divergf.F
+libf/dyn3d/divergst.F
+libf/dyn3d/divgrad.F
+libf/dyn3d/divgrad2.F
+libf/dyn3d/drsread.F
+libf/dyn3d/dteta1.F
+libf/dyn3d/dudv1.F
+libf/dyn3d/dudv2.F
+libf/dyn3d/dump2d.F
+libf/dyn3d/dynetat0.F
+libf/dyn3d/dynhist.F
+libf/dyn3d/dynredem.F
+libf/dyn3d/ener.h
+libf/dyn3d/enercin.F
+libf/dyn3d/etat0_lmd.F
+libf/dyn3d/etat0_net_drs_std.F
+libf/dyn3d/exner_hyb.F
+libf/dyn3d/flumass.F
+libf/dyn3d/flumass3d.F
+libf/dyn3d/flumass_scal.F
+libf/dyn3d/fxhyp.F
+libf/dyn3d/fluxstoke.F
+libf/dyn3d/fxy.F
+libf/dyn3d/fxyhyper.F
+libf/dyn3d/fxysinus.F
+libf/dyn3d/fyhyp.F
+libf/dyn3d/gcm.F
+libf/dyn3d/gcmtest.F
+libf/dyn3d/geopot.F
+libf/dyn3d/gr_dyn_fi.F
+libf/dyn3d/gr_fi_dyn.F
+libf/dyn3d/gr_int_dyn.F
+libf/dyn3d/gr_u_scal.F
+libf/dyn3d/gr_v_scal.F
+libf/dyn3d/grad.F
+libf/dyn3d/gradiv.F
+libf/dyn3d/gradiv2.F
+libf/dyn3d/gradsdef.h
+libf/dyn3d/grid_atob.F
+libf/dyn3d/grid_noro.F
+libf/dyn3d/groupe.F
+libf/dyn3d/groupeun.F
+libf/dyn3d/iniav.F
+libf/dyn3d/inicons0.F
+libf/dyn3d/iniconst.F
+libf/dyn3d/inidissip.F
+libf/dyn3d/inigeom.F
+libf/dyn3d/inigrads.F
+libf/dyn3d/initial0.F
+libf/dyn3d/integrd.F
+libf/dyn3d/interp_vert.F
+libf/dyn3d/juldate.F
+libf/dyn3d/laplacien.F
+libf/dyn3d/laplacien_gam.F
+libf/dyn3d/laplacien_rot.F
+libf/dyn3d/laplacien_rotgam.F
+libf/dyn3d/lectflux.F
+libf/dyn3d/limit_lmd.F
+libf/dyn3d/linear.F
+libf/dyn3d/linearb.F
+libf/dyn3d/logic.h
+libf/dyn3d/massbar.F
+libf/dyn3d/massbarxy.F
+libf/dyn3d/massdair.F
+libf/dyn3d/minmax.F
+libf/dyn3d/moy2.F
+libf/dyn3d/multipl.F
+libf/dyn3d/multscal.F
+libf/dyn3d/nxgrad.F
+libf/dyn3d/nxgrad_gam.F
+libf/dyn3d/nxgradst.F
+libf/dyn3d/nxgraro2.F
+libf/dyn3d/nxgrarot.F
+libf/dyn3d/offline.F
+libf/dyn3d/orogr.F
+libf/dyn3d/para_netcdf.h
+libf/dyn3d/paramet.h
+libf/dyn3d/pbar.F
+libf/dyn3d/pression.F
+libf/dyn3d/psextbar.F
+libf/dyn3d/qminimum.F
+libf/dyn3d/ran1.F
+libf/dyn3d/readhist.F
+libf/dyn3d/reduce_i.F
+libf/dyn3d/rotat.F
+libf/dyn3d/rotat_nfil.F
+libf/dyn3d/rotatf.F
+libf/dyn3d/rotatst.F
+libf/dyn3d/serre.h
+libf/dyn3d/sortvarc.F
+libf/dyn3d/sortvarc0.F
+libf/dyn3d/spline.F
+libf/dyn3d/splint.F
+libf/dyn3d/substr.F
+libf/dyn3d/temps.h
+libf/dyn3d/test_period.F
+libf/dyn3d/testgcm.F
+libf/dyn3d/testgcm2.F
+libf/dyn3d/testharm.F
+libf/dyn3d/tourpot.F
+libf/dyn3d/traceur.F
+libf/dyn3d/tracstoke.h
+libf/dyn3d/tracvl.F
+libf/dyn3d/vanleer.F
+libf/dyn3d/vitvert.F
+libf/dyn3d/vlsplt.F
+libf/dyn3d/wrgrads.F
+libf/dyn3d/writeav.F
+libf/filtrez/acc.F
+libf/filtrez/coefils.h
+libf/filtrez/eigen.F
+libf/filtrez/eigen_sort.F
+libf/filtrez/filtreg.F
+libf/filtrez/inifgn.F
+libf/filtrez/inifilr.F
+libf/filtrez/jacobi.F
+libf/filtrez/parafilt.h
+libf/grid/dimensions.h
+libf/grid/fxy_new.h
+libf/grid/fxy_reg.h
+libf/grid/fxy_sin.h
+libf/grid/fxyprim.h
+libf/phylmd/FCTTRE.h
+libf/phylmd/YOECUMF.h
+libf/phylmd/YOEGWD.h
+libf/phylmd/YOETHF.h
+libf/phylmd/YOMCST.h
+libf/phylmd/ajsec.F
+libf/phylmd/albedo.F
+libf/phylmd/clesphys.h
+libf/phylmd/clim.h
+libf/phylmd/clmain.F
+libf/phylmd/cltrac.F
+libf/phylmd/cltracrn.F
+libf/phylmd/conccm.F
+libf/phylmd/condsurf.F
+libf/phylmd/conflx.F
+libf/phylmd/conlmd.F
+libf/phylmd/dimphy.h
+libf/phylmd/dimsoil.h
+libf/phylmd/ecribin.F
+libf/phylmd/ecrireg.F
+libf/phylmd/fisrtilp.F
+libf/phylmd/fisrtilp_tr.F
+libf/phylmd/flxtr.F
+libf/phylmd/hgardfou.F
+libf/phylmd/homogene.F
+libf/phylmd/hydrol.F
+libf/phylmd/indicesol.h
+libf/phylmd/inifis.F
+libf/phylmd/initrrnpb.F
+libf/phylmd/minmaxqfi.F
+libf/phylmd/nflxtr.F
+libf/phylmd/nuage.F
+libf/phylmd/o3cm.F
+libf/phylmd/oasis.F
+libf/phylmd/oasis.h
+libf/phylmd/orbite.F
+libf/phylmd/orografi.F
+libf/phylmd/ozonecm.F
+libf/phylmd/phyetat0.F
+libf/phylmd/phyredem.F
+libf/phylmd/physiq.F
+libf/phylmd/phystoke.F
+libf/phylmd/phytrac.F
+libf/phylmd/phytractest.F
+libf/phylmd/raddim.h
+libf/phylmd/printflag.F
+libf/phylmd/raddimlw.h
+libf/phylmd/radepsi.h
+libf/phylmd/radiornpb.F
+libf/phylmd/radlwsw.F
+libf/phylmd/radopt.h
+libf/phylmd/regdim.h
+libf/phylmd/soil.F
+libf/phylmd/suphec.F
+libf/phylmd/transp.F
+libf/phylmd/wrgradsfi.F
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources_f90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources_f90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/liste_des_sources_f90	(revision 428)
@@ -0,0 +1,55 @@
+      USE ioipsl
+libf/bibio/writedynav.F
+       USE IOIPSL
+libf/bibio/initfluxsto.F
+       USE IOIPSL
+libf/bibio/inithist.F
+       USE IOIPSL
+libf/bibio/initdynav.F
+      USE ioipsl
+libf/bibio/writehist.F
+      USE IOIPSL
+libf/dyn3d/abort_gcm.F
+       USE IOIPSL
+libf/dyn3d/fluxstokenc.F
+      USE IOIPSL
+libf/dyn3d/dynredem.F
+      USE ioipsl
+libf/dyn3d/offlinenc.F
+      USE ioipsl
+libf/dyn3d/etat0_netcdf.F
+      USE IOIPSL
+libf/dyn3d/gcm.F
+      use IOIPSL
+libf/dyn3d/conf_gcm.F
+      USE ioipsl
+libf/dyn3d/startvar.F
+      USE ioipsl
+libf/dyn3d/create_limit.F
+      USE ioipsl
+libf/dyn3d/modif_etat0.F
+      USE ioipsl
+libf/phylmd/clmain.F
+      USE ioipsl
+libf/phylmd/physiq.F
+      USE ioipsl
+libf/phylmd/phytrac.F
+      USE ioipsl
+libf/phylmd/phystokenc.F
+       USE IOIPSL
+libf/phylmd/initphysto.F
+      USE ioipsl
+libf/phyold/clmain.F
+      USE ioipsl
+libf/phyold/physiq.F
+      USE ioipsl
+libf/phyold/phytrac.F
+      USE ioipsl
+libf/phyold/phystokenc.F
+       USE IOIPSL
+libf/phyold/initphysto.F
+libf/bibio/writephys.F90
+libf/phylmd/interface_surf.F90
+libf/phylmd/conf_phys.F90
+libf/phyold/interface_surf.F90
+libf/phyold/conf_phys.F90
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/makegcm
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/makegcm	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/makegcm	(revision 428)
@@ -0,0 +1,827 @@
+#!/bin/csh
+# $Header$
+#set verbose echo
+########################################################################
+# options par defaut pour la commande make
+########################################################################
+set dim="72x45x19"
+set physique=lmd
+set phys="PHYS=$physique"
+set include='-I$(LIBF)/grid -I$(LIBF)/bibio -I. '
+set ntrac = 4
+set filtre=filtrez
+set grille=reg
+set couple=false
+set veget=true
+set OPT_STACK='-Wf,-init stack=zero'
+set OPT_STACK=' '
+set OPTIMI='-C debug -eC'
+set OPTIMI=' '
+########################################################################
+# path a changer contenant les sources et les objets du modele
+########################################################################
+
+###### VERSION LMDZ.3.3
+set LMDGCM="`pwd`"
+#
+
+setenv localdir "`pwd`"
+  setenv LIBOGCM "`pwd`/lib"
+set MODIPSL=0
+echo $localdir | grep modipsl >& /dev/null
+if ( ! $status ) then
+  set MODIPSL=1
+  setenv LMDGCM $localdir
+  cd ../..
+  setenv LIBOGCM "`pwd`/lib"
+  setenv IOIPSLDIR $LIBOGCM
+  setenv MODIPSLDIR $LIBOGCM
+  cd $localdir
+  if ( `hostname` == rhodes ) then
+#    set NCDFINC=`grep sxnec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+#    set NCDFLIB=`grep sxnec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+     set NCDFINC="$NETCDF_I8R8"
+     set NCDFLIB="$NETCDF_I8R8"
+  else
+    if ( `hostname` == nymphea0 ) then
+      set NCDFINC=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+      set NCDFLIB=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+    else
+      echo 'Probleme de definition des variables NCDFINC et NCDFLIB'
+    endif 
+  endif 
+else
+  if ( ! $?LMDGCM ) then
+    echo You must initialize the variable LMDGCM in your environnement
+    echo for instance: "setenv LMDGCM /usr/myself/supergcm" in .cshrc
+    exit
+  endif
+  if ( ! $?LIBOGCM ) then
+    set LIBOGCM=$LMDGCM/libo
+  endif
+  if ( ! $?IOIPSLDIR ) then
+    echo You must initialize the variable IOIPSLDIR in your environnement
+    echo for instance: "setenv IOIPSLDIR /usr/myself/ioipsl" in .cshrc
+    exit
+  else
+      setenv MODIPSLDIR $IOIPSLDIR
+  endif
+  if ( ! $?NCDFLIB ) then
+    echo You must initialize the variable NCDFLIB in your environnement
+    echo for instance: "setenv NCDFLIB /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+  if ( ! $?NCDFINC ) then
+    echo You must initialize the variable NCDFINC in your environnement
+    echo for instance: "setenv NCDFINC /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+endif
+set model=$LMDGCM
+set libo=$LIBOGCM
+
+########################################################################
+#  Les differentes platformes reconnues
+########################################################################
+
+set HP=0
+set IBM=0
+set SUN=0
+set VPP=0
+set CRAY=0
+set DEC=0
+set LINUX=0
+set NEC=0
+set XNEC=0
+if ( `uname` == HP-UX ) then
+   set machine=HP
+   set HP=1
+else if (`uname` == UNIX_System_V ) then
+   set machine=VPP
+   set VPP=1
+else if (`uname` == SunOS ) then
+   set machine=SUN
+   set SUN=1
+else if ( `uname` == AIX ) then
+   set machine=IBM
+   set IBM=1
+else if ( `uname` == OSF1 ) then
+   set machine=ALPHA
+   set DEC=1
+else if ( `uname` == Linux ) then
+   set machine=LINUX
+   set LINUX=1
+else if ( `hostname` == atlas || `hostname` == axis  || `hostname` == etoile ) then
+   set machine=CRAY
+   set CRAY=1
+else if ( `uname` == SUPER-UX ) then
+   set machine=NEC
+   set NEC=1
+else if ( `hostname` == rhodes) then
+   set machine=XNEC
+   set XNEC=1
+else
+   echo Vous travaillez sur une machine non prevue par le reglement
+   exit
+endif
+
+if ( ! -d $libo )  then
+   mkdir $libo
+endif
+
+
+if $VPP then
+set netcdf=netcdf_v
+else 
+set netcdf=netcdf
+endif
+########################################################################
+#  Quelques initialisations de variables du shell.
+########################################################################
+
+set dyn=
+set opt_link=""
+set adjnt=""
+set opt_dep=""
+
+set optim=""
+set optimbis=""
+set optim90=""
+set oplink=""
+
+########################################################################
+#  Optimisations par defaut suivant les machines
+########################################################################
+
+echo "Optimisations par defaut suivant les machines"
+set libf=$model/libf
+#setenv localdir "LOCAL_DIR=`pwd`"
+#setenv localdir "`pwd`"
+cd $model
+if $CRAY then
+#   set optim="-Wf'-ei' -dp -Wf'-a static'"
+   set optimbis=" -DCRAY "
+   set optim90="-Wp'-P' -DCRAY -p$IOIPSLDIR "'-p$(LIBO) -eiv '
+   set optim="$optim90"
+   set oplink="-Wl'-DSTACK=128 -f indef' -L$IOIPSLDIR -lioipsl  -L$NCDFLIB -lnetcdf "
+   set mod_loc_dir=" "
+   set mod_suffix=" "
+else if $SUN then
+   set optim=" -fast "
+#   set optim=" -g "
+   set optimbis=" "
+   set optim90=" -fast -fixed "
+   set optimtru90=" -fast -free "
+   set opt_link="-lf77compat -L$MODIPSLDIR -lsechiba -lparameters -lstomate -lioipsl -L$NCDFLIB -lnetcdf "
+   set mod_loc_dir=$localdir
+   set mod_suffix=mod
+else if $HP then
+   set optim=" +U77 -O +E1 "
+   set optimbis=" "
+else if $IBM then
+   set optim=" -O3 -qtune=pwr2 -qarch=pwr2"
+   set optimbis=" "
+else if $VPP then
+#   set optim="-Dasuxm  -On, -g -Ad -Potilax -Eciplume -Si"
+#   set optimbis="  -Wv,-m3 -Wp,-DVPP -Z $LMDGCM/listage"
+   set optimbis=" -Wp,-DNC_DOUBLE -Ad -Z $LMDGCM/listage -X9"
+   set optim90="$optim $optimbis -X9 -w"
+   set mod_loc_dir=$MODIPSLDIR
+   set mod_suffix=mod
+else if $DEC then
+   set optim=" "
+   set optimbis=" "
+else if $LINUX then
+   set optim="-fast "
+   set optim90=" -fast "
+   set optimtru90=" -fast -c -Mfree -module $MODIPSLDIR "
+   set opt_link=" -Mfree -L /usr/local/pgi/linux86/lib -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$MODIPSLDIR -lsechiba -lparameters -lstomate -L$NCDFLIB -lnetcdf -lioipsl -Wl,-Bstatic -L/usr/lib/gcc-lib/i386-linux/2.95.2/"
+   set mod_loc_dir=$MODIPSLDIR
+   set mod_suffix=mod
+else if $NEC then
+   set optim90=' -clear -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+   set optimtru90=' -clear -f4 -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+   set optim="$optim90"
+   set optimbis=" "
+   set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lioipsl  $NCDFLIB -lnetcdf_i8r8_v "
+   set mod_loc_dir="."
+   set mod_suffix="mod"
+else if $XNEC then
+   set optim90=' -clear -float0 -ew -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume "'
+   set optimtru90=' -clear -f4 -float0 -ew -R2 -R3 -R4 -R5 -Wf,"-pvctl loopcnt=40000 fullmsg noassume"'
+   set optim="$optim90"
+   set optimbis=" "
+   set mod_suffix="mod"
+else
+   set optim=""
+   set optimbis=" "
+endif
+
+set nomlib=$machine
+
+########################################################################
+# lecture des options de mymake
+########################################################################
+
+top:
+if ($#argv > 0) then
+    switch ($1:q)
+
+    case -h:
+
+########################################################################
+# Manuel en ligne
+########################################################################
+more <<eod
+
+
+makegcm [Options] prog
+
+
+
+
+Par default, la commande makegcm:
+---------------------------------
+
+1. compile une serie de sous programmes se trouvant dans des sous-repertoires
+de $LMDGCM/libf.
+Les sous programmes sont ensuite stokes sur dans des librairies FORTRAN
+sur $LIBOGCM.
+
+2. Ensuite, makegcm compile le programme prog.f se trouvant par default sur
+$LMDGCM/libf/dyn3d et effectue le lien avec l ensemble des librairies.
+
+La variable '$LMDGCM' doit etre initialisee dans votre .cshrc ou en dur
+dans la comande makegcm.
+
+La commande makegcm est faite pour permettre de gerer en parallele des
+versions differentes du modele, compilees avec des options de compilation
+et des dimensions differentes sans avoir a chaque fois a recompiler tout
+le modele.
+
+Les librairies FORTRAN sont stoquees sur le directory $LIBOGCM.
+
+
+OPTIONS:
+--------
+
+Les options suivantes peuvent etre definies soit par defaut en editant le
+"script" makegcm, soit en interactif:
+
+-d imxjmxlm  ou im, jm, et lm sont resp. le nombre de longitudes, latitudes
+             et couches verticales. 
+
+-t ntrac   selectionne le nombre de traceur advectes par la dynamique.
+           Dans les versions courantes du modele terrestre on a par exemple
+           ntrac=2 pour l'eau vapeur et liquide
+
+             L'effet des options -d et -t est d'ecraser le fichier 
+             $LMDGCM/libf/grid/dimensions.h
+             qui contient sous forme de 4 PARAMETER FORTRAN les 3 dimensions
+             de la grille horizontale im, jm, lm plus le nombre de traceurs
+             advectes passivement par la dynamique ntrac, par un nouveu fichier
+             $LMDGCM/libf/grid/dimension/dimensions.im.jm.lm.tntrac
+             Si ce fichier n'existe pas encore, il est cree par le script
+             $LMDGCM/libf/grid/dimension/makdim
+
+-p PHYS    pour selectionner le jeu de parametrisations physiques avec
+           lequel on veut compiler le modele.
+           Le modele sera alors compile en prenant les sources des
+           parametrisations physiques dans le repertoire:
+            $LMDGCM/libf/phyPHYS
+
+-c false|true
+           pour selectionner le mode force (par defaut) ou couple
+
+-v true|false
+           pour selectionner la vegetation (par defaut) ou non
+
+-g grille  selectionne le type de grille qu'on veut utiliser.
+           L'effet de cette option est d'ecraser le fichier
+           $LMDGCM/libf/grid/fxyprim.h
+           avec le fichier
+           $LMDGCM/libf/grid/fxy_grille.h
+           grille peut prendre les valeurs:
+           1. reg pour la grille reguliere
+           2. sin pour avoir des points equidistants en sinus de la latitude
+           3. new pour pouvoir zoomer sur une partie du globe
+
+-O "optimisation fortran" ou les optimisations fortran sont les options de la
+            commande f77
+
+-include path
+           Dans le cas ou on a dans des sous programmes des fichiers 
+           #include (cpp) qui se trouve sur des repertoires non references
+           par defaut
+
+-adjnt     Pour compiler la l'adjoint du code dynamique
+
+-filtre  filtre
+           Pour choisir le filtre en longitude dans les regions polaires.
+           "filtre" correspond au nom d'un repertoire se trouvant sur
+           $LMDGCM/libf. Le filtre standard du modele est "filtrez" qui peut
+           etre utilise aussi bien pour une grille reguliere que pour une 
+           grille zoomee en longitude.
+
+-link "-Ldir1 -lfile1 -Ldir2 -lfile2 ..."
+          Pour rajouter un lien avec les librairies FORTRAN
+          libfile1.a, libfile2.a ... se trouvant respectivement sur les
+          repertoires dir1, dir2 ...
+          Si dirn est un repertoire dont le chemin est automatique (comme
+          par exemple /usr/lib ...) il n'est pas besoin de specifier -Ldirn.
+
+Auteur: Frederic Hourdin  (hourdin@lmd.jussieu.fr)
+eod
+exit
+
+########################################################################
+# Lecture des differentes options
+########################################################################
+
+    case -d:
+        set dim=$2 ; shift ; shift ; goto top
+                        
+    case -O:
+        set optim="$2" ; shift ; shift ; goto top
+
+     case -p
+        set physique="$2" ; set phys="PHYS=$physique" ; shift ; shift ; goto top
+
+     case -g
+        set grille="$2" ; shift ; shift ; goto top
+
+     case -c
+        set couple="$2" ; shift ; shift ; goto top
+
+     case -v
+        set veget="$2" ; shift ; shift ; goto top
+
+     case -t
+        set ntrac=$2 ; shift ; shift ; goto top
+
+     case -include
+        set include="$include -I$2" ; shift ; shift ; goto top
+
+     case -adjnt
+        set opt_dep="$opt_dep adjnt" ; set adjnt="-ladjnt -ldyn3d "
+        set optim="$optim -Dadj" ; shift ; goto top
+
+     case -filtre
+        set filtre=$2 ; shift ; shift ; goto top
+
+     case -link
+        set opt_link="$opt_link $2" ; shift ; shift ; goto top
+
+     case -debug
+        if $HP then
+           set optim=" -g "
+        else if $SUN then
+           setenv PARALLEL 2
+           set optim=" -g -C "
+           set optim=" -g "
+           set optim90=" -fixed -g -C "
+           set optim90=" -fixed -g "
+           set optimtru90=" -free -g -C "
+#           set optim=" -g "
+#           set optim90=" -fixed -g "
+#           set optimtru90=" -free -g "
+        else if $CRAY then
+           set optim="$optim"" -g "
+           set optim90="$optim90"" -G1 "
+        else if $LINUX then
+           set optim="$optim"" -g -Mbounds -C "
+           set optim90="$optim90"" -g -Mbounds -C "
+        else 
+           echo pas d option debug predefinie pour cette machine
+           exit
+        endif
+        shift ; goto top
+
+     default
+        set code="$1" ; shift ; goto top
+
+   endsw
+endif
+
+########################################################################
+# cas special sans physique
+########################################################################
+if ( "$physique" == 'nophys' ) then
+   set phys="L_PHY= LIBPHY="
+endif
+
+########################################################################
+# choix du nombre de traceur par defaut si il n'a pas ete choisi,
+# suivant la physique
+########################################################################
+
+if ( $ntrac == 0  ) then
+    if ( "$physique" == 'nophys' ) then
+        set ntrac=1
+    else if ( "$physique" == 'lmd' ) then
+        set ntrac=2
+    else if ( "$physique" == 'lmd_test_li' ) then
+        set ntrac=2
+    else if ( "$physique" == 'ec' ) then
+        set ntrac=1
+    else
+        set ntrac = 1
+    endif
+endif
+
+########################################################################
+#subtilites sur le nom de la librairie
+########################################################################
+
+\rm -f tmp ; touch tmp
+\rm -f tmp90 ; touch tmp90
+foreach i ( $optim )
+   echo $i | sed -e 's/\"//g' -e "s/\'//g" -e 's/-//g'  >> tmp
+end
+set suf=
+foreach i ( `sort tmp | uniq ` )
+   set suf=$suf$i
+end
+if ( ! $IBM ) then
+   set nomlib="$nomlib$suf"
+endif
+if ( $DEC ) then
+   set nomlib=DEC
+endif
+if ( $IBM ) then
+   set dim=`echo $dim | sed -en 's/[^0-9]/ /g'`
+   set dim_=`echo $dim | sed -en 's/[^0-9]/_/g'`
+else if ( $SUN ) then
+   set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` 
+   set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'`
+else
+   set dim=`echo $dim | sed -n -e 's/[^0-9]/ /gp'`
+   set dim_=`echo $dim | sed -n -e 's/[^0-9]/_/gp'`
+endif
+set nomlib=${nomlib}_${dim_}_t${ntrac}_$grille
+## M-A-F nomlib trop long sur CRAY pour ar
+if ( $CRAY ) then
+    set nomlib=F90_${dim_}_t${ntrac}
+endif
+if ( $NEC || $XNEC ) then
+    set nomlib=F90_${dim_}_t${ntrac}
+endif
+echo calcul de la dimension
+set dimc=`echo $dim | wc -w`
+
+if ( "$dimc" == "2" ) then
+set include="$include "'-I$(LIBF)/dyn2d '
+set dimh=$dim
+else
+set include="$include "'-I$(LIBF)/dyn3d '
+set dimh=`echo $dim | awk ' { print $1 "." $2 } '`
+endif
+echo $dimc
+
+########################################################################
+# path pour les #include
+########################################################################
+
+if ( $XNEC ) then
+  set include="$include $NCDFINC -I$IOIPSLDIR"
+else
+  set include="$include -I$NCDFINC -I$IOIPSLDIR"
+endif
+echo $include
+
+########################################################################
+# Gestion des dimensions du modele.
+# on cree ou remplace le fichier des dimensions/nombre de traceur
+########################################################################
+
+cd $libf/grid
+if ( -f dimensions.h ) then
+echo 'ATTENTION: vous etes sans doute en train de compiler le modele par ailleurs'
+echo "Attendez que la premiere compilation soit terminee pour relancer la suivante."
+echo "Si vous etes sur que vous ne compilez pas le modele par ailleurs,"
+echo  vous pouvez continuer en repondant oui.
+echo "Voulez-vous vraiment continuer?"
+if ( $< == "oui" ) then
+\rm -f $libf/grid/dimensions.h
+else
+exit
+endif
+endif
+
+cd dimension
+makdim $ntrac $dim
+cat $libf/grid/dimensions.h
+
+cd $LMDGCM
+set libo=$libo/$nomlib
+if ( ! -d $libo )  then
+   mkdir $libo
+   cd $model
+endif
+
+########################################################################
+# Differentes dynamiques (3d, 2d, 1d)
+########################################################################
+
+set dimension=`echo $dim | wc -w`
+echo dimension $dimension
+if ( $dimension == 1 ) then
+echo pas de dynamique
+set dyn="L_DYN= DYN= L_FILTRE= DIRMAIN=phy$physique "
+endif
+endif
+cd $model
+if ( $dimension == 3 ) then
+cd libf/grid
+\rm fxyprim.h
+cp -p fxy_${grille}.h fxyprim.h
+endif
+
+######################################################################
+#   Traitement special pour le nouveau rayonnement de Laurent Li.
+######################################################################
+
+if ( -f $libf/phy$physique/raddim.h ) then
+ if ( -f $libf/phy$physique/raddim.$dimh.h ) then
+  \rm -f $libf/phy$physique/raddim.h
+  cp -p $libf/phy$physique/raddim.$dimh.h $libf/phy$physique/raddim.h
+  echo $libf/phy$physique/raddim.$dimh.h 
+  cat $libf/phy$physique/raddim.$dimh.h 
+  cat $libf/phy$physique/raddim.h
+ else
+  echo On peut diminuer la taille de l executable en creant
+  echo le fichier $libf/phy$physique/raddim.$dimh.h
+  \cp -p $libf/phy$physique/raddim.defaut.h $libf/phy$physique/raddim.h
+ endif
+endif
+
+######################################################################
+# Gestion du filtre qui n'existe qu'en 3d.
+######################################################################
+
+if ( `expr $dimc \> 2` == 1 ) then
+   set filtre="FILTRE=$filtre"
+else
+   set filtre="FILTRE= L_FILTRE= "
+endif
+echo MACRO FILTRE $filtre
+
+echo $dimc
+
+########################################################################
+#  utilisation des vraies routines de couplage si on est en couple
+########################################################################
+if ( $couple == 'true' ) then
+  banner couple
+  pwd
+  if ( `diff $libf/phylmd/oasis.F $libf/phylmd/oasis.true | wc -w` ) then
+   \cp $libf/phylmd/oasis.F $libf/phylmd/oasis.dummy
+   \cp $libf/phylmd/oasis.true $libf/phylmd/oasis.F
+  endif
+else
+  if ( `diff $libf/phylmd/oasis.F $libf/phylmd/oasis.dummy | wc -w` ) then
+   \cp $libf/phylmd/oasis.F $libf/phylmd/oasis.true
+   \cp $libf/phylmd/oasis.dummy $libf/phylmd/oasis.F
+  endif
+endif
+########################################################################
+#  Avant de lancer le make, on recree le makefile si necessaire
+########################################################################
+# c'est a dire dans 3 cas:
+# 1. si la liste des fichiers .F et .h a ete modifiee depuis la
+#    derniere creation du makefile
+# 2. si le fichier contenant cette liste "liste_des_sources"
+#    n'existe pas.
+# 3. Si le makefile n'existe pas.
+########################################################################
+
+cd $model
+find libf -name '*.[Fh]' -print >! tmp77
+find libf -name '*.[Fh]' -exec egrep -i " *use *ioipsl" {} \; -print >! tmp90
+find libf -name '*.[Fh]90' -print >> tmp90
+
+if (    `diff tmp77 liste_des_sources_f77 | wc -w` \
+     || `diff tmp90 liste_des_sources_f90 | wc -w` \
+     || ! -f makefile \
+     || ! -f liste_des_sources_f90 \
+     || ! -f liste_des_sources_f77 ) then
+        echo les fichiers suivants ont ete crees ou detruits
+        echo ou les fichiers suivants sont passes ou ne sont plus en Fortran 90
+        diff liste_des_sources_f77 tmp77
+        diff liste_des_sources_f90 tmp90
+        \cp tmp77 liste_des_sources_f77
+        \cp tmp90 liste_des_sources_f90
+        echo On recree le makefile
+        ./create_make_gcm >! tmp
+        \mv tmp makefile
+        echo Nouveau makefile cree.
+endif
+
+########################################################################
+#  Execution de la comande make
+########################################################################
+
+echo PHYSIQUE $phys
+echo dynamique $dyn $dimension
+echo OPTIM="$optim" $filtre LIBO=$libo $dyn PHYS=$phys DIM=$dimc PROG=$code
+echo PATH pour les fichiers INCLUDE $include
+echo OPLINK="$oplink"
+
+if $HP then
+   set f77='fort77 +OP'
+   set f90='jensaisrien'
+   set opt_link="$opt_link -lm"
+else  if $VPP then
+   set f77=frt
+   set f90=$f77
+   if ($couple == true) then
+     set opt_link="-Wg,-c $MODIPSLDIR/liboasis2.4_mpi2.a /usr/lang/mpi2/lib64/libmpi.a /usr/lang/mpi2/lib64/libmp.a -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+     set oplink="-Wl,-t,-P,-dy "
+   else
+     set opt_link="-Wg,-c -L$MODIPSLDIR -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+     set oplink="-Wl,-t,-dy "
+   endif
+   if ($veget == true) then
+     set opt_link="$opt_link -lsechiba -lparameters -lstomate -lioipsl /usr/local/lib/lib64/libnetcdf_cc_31.a"
+   endif
+else if $CRAY then
+   set f77=f90
+   set f90=f90
+else if $LINUX then
+   set f77=pgf90
+   set f90=pgf90
+else if $SUN then
+   set f77=f90
+   set f90=f90
+else if $NEC then
+   set f77=f90
+   set f90=f90
+   set opt_link="-L$MODIPSLDIR"
+   if ($veget == true) then
+     set opt_link="$opt_link -lsechiba -lparameters -lstomate"
+   endif
+   if ($couple == true) then
+     set opt_link="$opt_link -lioipsl -loasis2.4_mpi2 -float0 -ew -P static $NCDFLIB "
+   else
+     set opt_link="$opt_link -L$MODIPSLDIR -lioipsl -float0 -ew -P static $NCDFLIB "
+   endif
+   set mod_loc_dir="./"
+else if $XNEC then
+   set f77=sxmpif90
+   set f90=sxmpif90
+   if $MODIPSL then
+     set opt_link="-L$MODIPSLDIR"
+     if ($veget == true) then
+       set opt_link="$opt_link -lsxsechiba -lsxparameters -lsxstomate"
+     endif
+     if ($couple == true) then
+       set opt_link="$opt_link -lsxioipsl -loasis2.4_mpi2 -float0 -ew -P static $NCDFLIB "
+     else
+       set opt_link="$opt_link -lsxioipsl -float0 -ew -P static $NCDFLIB "
+     endif
+   else
+     set opt_link=" -C hopt -float0 -ew -P static -L$MODIPSLDIR -lsxsechiba -lsxparameters -lsxstomate -lsxioipsl $NETCDF_I8R8 "
+   endif
+   set mod_loc_dir="./"
+else
+   set f77=f77
+   set f90=f90
+endif
+
+cd $model
+
+if $VPP then
+set make="gmake RANLIB=ls"
+else if $CRAY then
+set make="make RANLIB=ls"
+else if $NEC then
+set make="make RANLIB=ls"
+else if $LINUX then
+set make="make -k RANLIB=ranlib"
+else if $XNEC then
+set make="gmake RANLIB=ls"
+else
+set make="make RANLIB=ranlib"
+endif
+
+
+
+#
+# les deux test suivants sont "temporaires" pour pallier des "faiblesses" du 
+# compilateur fortran Sun: f90: SC4.0 11 Sep 1995 FORTRAN 90 1.1
+#
+#if ($code == 'create_limit' && $SUN) then
+#   set link=f77
+#   set opt_link="-L$NCDFLIB -lnetcdf"
+#endif
+
+#if ($code == 'create_etat0' && $SUN) then
+#   if ( ! -f $libo/libdyn3d.a ) then
+#     echo "Priere de compiler gcm en premier pour des raisons d'optimisation"
+#     \rm $libf/grid/dimensions.h
+#     exit
+#   endif
+#   set optim=" -dalign "
+#   set optim90=" -dalign -fixed "
+#   set opt_link="-L$IOIPSLDIR -lioipsl  -L$NCDFLIB -lnetcdf"
+#   set link="$f90 $optim90"
+#   touch $LMDGCM/libf/dyn3d/startvar.F
+#   touch $LMDGCM/libf/dyn3d/etat0_netcdf.F
+#endif
+
+#
+# etat0_netcdf a besoin d'info de la physique
+# A revoir
+set include="$include"' -I$(LIBF)/phylmd'
+#
+# le programme principal create_limit a besoin de l'info du module
+# startvar: on met donc libo dans les include pour Nec
+set include="$include"' -I$(LIBO)'
+
+
+#################################################################
+# Execution de la comande make... ENFIN!
+#################################################################
+
+if $VPP then
+  set optim90=" $optim90 -Am -M$libo"
+  set optimtru90="$optim90"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $SUN then
+ set optim90=" $optim90 -M$libo -M$MODIPSLDIR "
+ set optimtru90=" $optimtru90 -M$libo -M$MODIPSLDIR "
+ set optim="$optim90"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $NEC then
+ set optim90=" $optim90 -I$libo "
+else if $XNEC then
+ set optim90=" $optim90 -I$libo "
+ set optimtru90=" $optimtru90 -I$libo "
+else if $LINUX then
+ set optim90=" $optim90 -module $libo "
+ set optim="$optim90"
+ set mod_loc_dir=$libo
+ \cp /d3/fairhead/sechiba/ioipsl/*.mod $libo
+ \cp $IOIPSLDIR/*.mod $libo
+endif
+
+set link="$f90 $optim90"
+
+set ar=ar
+
+if $XNEC then
+  set link="sxld $opt_link"
+  set link="$f90 "
+#  set ar=sxar
+endif
+
+
+cd $localdir
+
+echo $make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+OPTIM="$optim$optimbis" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+L_ADJNT="$adjnt" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+$make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+OPTIM="$optim$optimbis" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+L_ADJNT="$adjnt" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+\rm -f $libf/grid/dimensions.h
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/offline.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/offline.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/offline.def	(revision 428)
@@ -0,0 +1,9 @@
+T
+4
+T
+-2.
+48.1
+1
+T
+6
+2
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/orchidee.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/orchidee.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/orchidee.def	(revision 428)
@@ -0,0 +1,43 @@
+#
+# SECHIBA
+#
+STOMATE_OK_CO2=FALSE
+# STOMATE_OK_STOMATE is not set
+# STOMATE_OK_DGVM is not set
+# STOMATE_WATCHOUT is not set
+#SECHIBA_restart_in=default
+SECHIBA_restart_in=start_sech.nc
+SECHIBA_rest_out=sechiba_rest.nc
+SECHIBA_reset_time=y
+SECHIBA_reset_time is not set
+OUTPUT_FILE=sechiba_out.nc
+WRITE_STEP=2592000
+SECHIBA_HISTLEVEL=10
+STOMATE_OUTPUT_FILE=stomate_history.nc
+STOMATE_HIST_DT=10.
+STOMATE_HISTLEVEL=0
+SECHIBA_DAY=0.0
+SECHIBA_ZCANOP=0.5
+DT_SLOW=86400.
+# IMPOSE_VEG is not set
+VEGETATION_FILE=carteveg5km.nc
+DIFFUCO_LEAFCI=233.
+CONDVEG_SNOWA=default
+# IMPOSE_AZE is not set
+SOILALB_FILE=soils_param.nc
+SOILTYPE_FILE=soils_param.nc 
+ENERBIL_TSURF=280.
+HYDROL_SNOW=0.0
+HYDROL_SNOWAGE=0.0
+HYDROL_SNOWICE=0.0
+HYDROL_SNOWICEAGE=0.0
+HYDROL_HDRY=1.0
+HYDROL_HUMR=1.0
+HYDROL_BQSB=default
+HYDROL_GQSB=0.0
+HYDROL_DSG=0.0
+HYDROL_DSP=default
+HYDROL_QSV=0.0
+THERMOSOIL_TPRO=280.
+RIVER_ROUTING=y
+ROUTING_FILE=routing.nc
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/physiq.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/physiq.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/physiq.def	(revision 428)
@@ -0,0 +1,39 @@
+#
+## $Header$
+#
+#
+# Automatically generated make config: don't edit
+#
+
+OCEAN=force
+VEGET=y
+OK_journe=n
+OK_mensuel=y
+OK_instan=n
+#
+# parametres KE
+#
+epmax = .99
+ok_adj_ema = n
+iflag_clw = 1
+# 
+# parametres nuages
+#
+cld_lc_lsc = 2.6e-4
+cld_lc_con = 2.6e-4
+cld_tau_lsc = 3600.
+cld_tau_con = 3600.
+ffallv_lsc = 1.
+ffallv_con = 1.
+coef_eva = 2.e-5
+reevap_ice = y
+iflag_cldcon = 3
+iflag_pdf = 0
+fact_cldcon = 1.
+facttemps = 1.e-4
+ok_newmicro = y
+ratqsbas = 0.01
+ratqshaut = 0.8
+rad_froid = 35
+if_ebil = 2
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/proc
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/proc	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/proc	(revision 428)
@@ -0,0 +1,16 @@
+#! /bin/sh
+touch difdyn
+for i in /users/fairhead/modele/source/LMDZ.3.2/libf/dyn3d/*.F
+ do
+  ls $i
+  echo "======== $i =================">>difdyn
+  sdiff -s $i libf/dyn3d/.  >>difdyn
+  echo "=============================">>difdyn
+done
+for i in /users/fairhead/modele/source/LMDZ.3.2/libf/dyn3d/*.h
+ do
+  ls $i
+  echo "======== $i =================">>difdyn
+  sdiff -s $i libf/dyn3d/.  >>difdyn
+  echo "=============================">>difdyn
+done
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def	(revision 428)
@@ -0,0 +1,18 @@
+#
+# $Header$
+#
+INCLUDEDEF=physiq.def
+INCLUDEDEF=gcm.def
+INCLUDEDEF=orchidee.def
+## Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici )
+dayref=1
+##  Annee de l'etat  initial (   avec  4  chiffres   )
+anneeref=1979
+## Nombre de jours d'integration
+nday=30
+## periode de sortie des variables de controle (en pas)
+iconser=240
+## periode d'ecriture du fichier histoire (en jour)
+iecri=1
+## periode de stockage fichier dyn_hist_ave et dynzon (en jour)
+periodav=30.
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def.10jours
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def.10jours	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/run.def.10jours	(revision 428)
@@ -0,0 +1,187 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici ) 
+   dayref
+ 181
+
+-  Annee de l'etat  initial (   avec  4  chiffres   )                        
+   anneeref
+ 1998
+
+- Nombre de jours d'integration                                         
+     nday
+ 10
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 240
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 240
+
+- periode d'ecriture du fichier histoire (en jour)                      
+    iecri
+ 1
+
+- periode de stockage fichier histmoy (en jour)                         
+ periodav
+ 1.
+
+- 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
+ 7200.
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+ tetagrot
+ 7200.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 7200.
+
+- 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
+ 5
+
+- frequence (en  jours ) de l'ecriture du fichier histphy               
+ ecritphy
+ 1
+
+-  Cycle diurne  ou non                 
+ cycle_diurne
+ T
+
+-  Soil Model  ou non               
+ soil_model
+ T
+
+-  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
+ F
+
+- 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
+ 0.
+
+- latitude en degres du centre du zoom                                  
+   clat
+ 0.
+
+- facteur de grossissement du zoom,selon longitude                      
+  grossismx
+ 1.0
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.0
+
+-  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.0
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.0
+
+-  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
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/compdeb
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/compdeb	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/compdeb	(revision 428)
@@ -0,0 +1,13 @@
+#!/bin/csh
+
+# choix de la resolution
+#=======================
+#set res=48x32x19
+
+# compilation
+#============
+set compile="/home_ipsl/mafipsl/LMDZ.3.3/makegcm " 
+
+# Creation des executables
+#=========================
+$compile gcm        # le gcm proprement dit.
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cp2netcdf
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cp2netcdf	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cp2netcdf	(revision 428)
@@ -0,0 +1,14 @@
+#!/bin/csh
+
+# choix de la resolution
+#=======================
+#set res=48x32x19
+
+# compilation
+#============
+set compile="/home_ipsl/mafipsl/LMDZ.3.3/makegcm " 
+
+# Creation des executables
+#=========================
+$compile etat0_lmd        # fabrique les start.nc et startphy.nc
+$compile limit_lmd        # fabrique les limit.nc
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cpnetcdf
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cpnetcdf	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/cpnetcdf	(revision 428)
@@ -0,0 +1,13 @@
+#!/bin/csh
+
+# choix de la resolution
+#=======================
+#set res=48x32x19
+
+# compilation
+#============
+set compile="/home_ipsl/mafipsl/LMDZ.3.3/makegcm " 
+
+# Creation des executables
+#=========================
+$compile gcm        # le gcm proprement dit.
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/run.def
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/run.def	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/script/run.def	(revision 428)
@@ -0,0 +1,188 @@
+B
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici ) 
+   dayref
+ 181
+
+-  Annee de l'etat  initial (   avec  4  chiffres   )                        
+   anneeref
+ 1998
+
+- Nombre de jours d'integration                                         
+     nday
+ 10
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 240
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 240
+
+- periode d'ecriture du fichier histoire (en jour)                      
+    iecri
+ 1
+
+- periode de stockage fichier histmoy (en jour)                         
+ periodav
+ 1.
+
+- 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
+ 7200.
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+ tetagrot
+ 7200.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 7200.
+
+- 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
+ 5
+
+- frequence (en  jours ) de l'ecriture du fichier histphy               
+ ecritphy
+ 1
+
+-  Cycle diurne  ou non                 
+ cycle_diurne
+ T
+
+-  Soil Model  ou non               
+ soil_model
+ T
+
+-  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
+ 0.
+
+- latitude en degres du centre du zoom                                  
+   clat
+ 0.
+
+- facteur de grossissement du zoom,selon longitude                      
+  grossismx
+ 1.0
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.0
+
+-  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.0
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.0
+
+-  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
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp	(revision 428)
@@ -0,0 +1,4 @@
+clear
+float0
+ew
+R5
Index: /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp90
===================================================================
--- /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp90	(revision 428)
+++ /LMDZ.3.3/tags/IPSL-CM4_v1x1/tmp90	(revision 428)
@@ -0,0 +1,45 @@
+      USE ioipsl
+libf/bibio/writedynav.F
+       USE IOIPSL
+libf/bibio/initfluxsto.F
+       USE IOIPSL
+libf/bibio/inithist.F
+       USE IOIPSL
+libf/bibio/initdynav.F
+      USE ioipsl
+libf/bibio/writehist.F
+      USE IOIPSL
+libf/dyn3d/abort_gcm.F
+       USE IOIPSL
+libf/dyn3d/fluxstokenc.F
+      USE IOIPSL
+libf/dyn3d/dynredem.F
+      USE IOIPSL
+libf/dyn3d/gcmtest.F
+      USE ioipsl
+libf/dyn3d/offlinenc.F
+      USE ioipsl
+libf/dyn3d/etat0_netcdf.F
+      USE IOIPSL
+libf/dyn3d/gcm.F
+      use IOIPSL
+libf/dyn3d/conf_gcm.F
+      USE ioipsl
+libf/dyn3d/startvar.F
+      USE ioipsl
+libf/dyn3d/create_limit.F
+      USE ioipsl
+libf/dyn3d/modif_etat0.F
+      USE ioipsl
+libf/phylmd/clmain.F
+      USE ioipsl
+libf/phylmd/physiq.F
+      USE ioipsl
+libf/phylmd/phytrac.F
+      USE ioipsl
+libf/phylmd/phystokenc.F
+       USE IOIPSL
+libf/phylmd/initphysto.F
+libf/bibio/writephys.F90
+libf/phylmd/interface_surf.F90
+libf/phylmd/conf_phys.F90
