Index: LMDZ.3.3/branches/LF/README
===================================================================
--- LMDZ.3.3/branches/LF/README	(revision 3)
+++ LMDZ.3.3/branches/LF/README	(revision 3)
@@ -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/branches/LF/create_make_gcm
===================================================================
--- LMDZ.3.3/branches/LF/create_make_gcm	(revision 3)
+++ LMDZ.3.3/branches/LF/create_make_gcm	(revision 3)
@@ -0,0 +1,190 @@
+#!/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
+#
+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
+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    ='
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Option de compilation FORTRAN"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+   echo 'COMPILE = $(F77) $(OPTIM) $(INCLUDE) -c'
+   echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c'
+   echo 'LINK    = f90'
+   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) ;\'
+if [ "$CRAY" = '0' ] ; then
+echo '	cd $(LOCAL_DIR); \'
+#echo '	$(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
+echo '	$(COMPILE) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
+else
+echo '	$(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F ; \'
+fi
+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`" != "" ] ; 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
+#
+      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
+         F90=0 ; egrep -i '^ *use ' $fili.F > /dev/null 2>&1 && F90=1
+                 egrep -i '^ *module ' $fili.F > /dev/null 2>&1 && F90=1
+         str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$fili.F
+         [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F
+         for stri in ` ( sed -n "/\#include/s/\#include//p" $fili.F | sed 's/\"//g' ; egrep -i '^ *use ' $fili.F | awk ' { print $2 } ' ) `
+         do
+            if [ -f $stri ] ; then
+               echo $str1 \\
+               str1='$(LIBF)/'$diri'/'$stri
+            else
+               if [ -f $stri.F ] ; then
+                  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'/'$fili'.F ; \'
+	 else
+            echo '	cd $(LOCAL_DIR); \'
+	    echo '	$(COMPILE90) $(LIBF)/'$diri'/'$fili'.F ; \'
+            MODU=0; egrep -i ' *module ' $fili.F> /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
+         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/branches/LF/initialisation
===================================================================
--- LMDZ.3.3/branches/LF/initialisation	(revision 3)
+++ LMDZ.3.3/branches/LF/initialisation	(revision 3)
@@ -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/branches/LF/libf/bibio/initdynav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/initdynav.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/bibio/initdynav.F	(revision 3)
@@ -0,0 +1,165 @@
+      subroutine initdynav(infile,day0,anne0,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. 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
+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
+      CALL ymds2ju(zan, 1, 1, 0.0, zjulian)
+      zjulian = zjulian + day0
+      tau0 = 0
+      
+      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, jjp1, rlat,
+     .             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  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/branches/LF/libf/bibio/inithist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/inithist.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/bibio/inithist.F	(revision 3)
@@ -0,0 +1,194 @@
+      subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,nq,fileid,
+     .                    filevid)
+
+       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 "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
+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
+      CALL ymds2ju(zan, 1, 1, 0.0, zjulian)
+      zjulian = zjulian + day0
+      tau0 = 0
+      
+      do jj = 1, jjp1
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonu(ii) * 180. / pi
+          rlat(ii,jj) = rlatu(jj) * 180. / pi
+        enddo
+      enddo
+       
+      call histbeg(infile, iip1, rlong, jjp1, rlat,
+     .             1, iip1, 1, jjp1,
+     .             tau0, zjulian, tstep, uhoriid, fileid)
+C
+C  Creation du fichier histoire pour la grille en V (oblige pour l'instant,
+C  IOIPSL ne permet pas de grilles avec des nombres de point differents dans 
+C  un meme fichier)
+
+      do jj = 1, jjm
+        do ii = 1, iip1
+          rlong(ii,jj) = rlonv(ii) * 180. / pi
+          rlat(ii,jj) = rlatv(jj) * 180. / pi
+        enddo
+      enddo
+
+      call histbeg('dyn_histv.nc', iip1, rlong, jjm, rlat,
+     .             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/branches/LF/libf/bibio/lnblnk.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/lnblnk.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/bibio/lnblnk.F	(revision 3)
@@ -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/branches/LF/libf/bibio/writedynav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/writedynav.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/bibio/writedynav.F	(revision 3)
@@ -0,0 +1,134 @@
+      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 ndex(1),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
+C
+C  Initialisations
+C
+      str='q  '
+      ndex(1) = 0
+      ok_sync = .TRUE.
+
+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', time, us, 
+     .               iip1*jjp1*llm, ndex)
+C
+C  Vents V scalaire
+C
+      call gr_v_scal(llm, vnat, vs)
+      call histwrite(histid, 'v', time, vs, 
+     .               iip1*jjp1*llm, ndex)
+C
+C  Temperature moyennee
+C
+      do ii = 1, ijp1llm
+        tm(ii) = teta(ii) * ppk(ii)/cpp
+      enddo
+      call histwrite(histid, 'temp', time, tm, 
+     .                iip1*jjp1*llm, ndex)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', time, phi, 
+     .                iip1*jjp1*llm, ndex)
+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, time, q(:,:,iq), 
+     .                   iip1*jjp1*llm, ndex)
+        enddo
+      endif
+C
+C  Masse
+C
+       call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex)
+C
+C  Pression au sol
+C
+       call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex)
+C
+C  Geopotentiel au sol
+C
+       call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex)
+C
+C  Fin
+C
+      if (ok_sync) call histsync
+      return
+      end
Index: LMDZ.3.3/branches/LF/libf/bibio/writehist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/bibio/writehist.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/bibio/writehist.F	(revision 3)
@@ -0,0 +1,125 @@
+      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 ndex(1),iq, ii, ll
+      character*3 str
+      logical ok_sync
+C
+C  Initialisations
+C
+      str='q  '
+      ndex(1) = 0
+      ok_sync =.TRUE.
+C
+C  Appels a histwrite pour l'ecriture des variables a sauvegarder
+C
+C  Vents U
+C
+      call histwrite(histid, 'ucov', time, ucov, 
+     .               iip1*jjp1*llm, ndex)
+
+C
+C  Vents V
+C
+      call histwrite(histvid, 'vcov', time, vcov, 
+     .               iip1*jjm*llm, ndex)
+
+C
+C  Temperature potentielle
+C
+      call histwrite(histid, 'teta', time, teta, 
+     .                iip1*jjp1*llm, ndex)
+C
+C  Geopotentiel
+C
+      call histwrite(histid, 'phi', time, phi, 
+     .                iip1*jjp1*llm, ndex)
+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, time, q(:,:,iq), 
+     .                   iip1*jjp1*llm, ndex)
+        enddo
+      endif
+C
+C  Masse
+C
+      call histwrite(histid, 'masse', time, masse, iip1*jjp1, ndex)
+C
+C  Pression au sol
+C
+      call histwrite(histid, 'ps', time, ps, iip1*jjp1, ndex)
+C
+C  Geopotentiel au sol
+C
+      call histwrite(histid, 'phis', time, phis, iip1*jjp1, ndex)
+C
+C  Fin
+C
+      if (ok_sync) call histsync
+      return
+      end
Index: LMDZ.3.3/branches/LF/libf/dyn3d/LISEZMOI
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/LISEZMOI	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/LISEZMOI	(revision 3)
@@ -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/branches/LF/libf/dyn3d/abort_gcm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/abort_gcm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/abort_gcm.F	(revision 3)
@@ -0,0 +1,31 @@
+      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
+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/branches/LF/libf/dyn3d/add_tend.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/add_tend.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/add_tend.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/add_vec.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/add_vec.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/add_vec.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/addfi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/addfi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/addfi.F	(revision 3)
@@ -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 qtest
+      PARAMETER ( qtest = 1.0e-30 )
+
+      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
+
+      IF( alphax.NE.0. )   THEN
+        DO  k    = 1, llm
+         DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+          xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+         ENDDO
+          tpn      = SSUM(iim,xpn,1)/ apoln
+          tps      = SSUM(iim,xps,1)/ apols
+
+         DO ij   = 1, iip1
+          pteta(   ij   ,k)  = tpn
+          pteta(ij+ip1jm,k)  = tps
+         ENDDO
+        ENDDO
+      ENDIF
+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
+
+c
+
+      DO iq = 1, 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), qtest )
+ccc              pq(j,k,iq)=qtest
+            ENDDO
+         ENDDO
+      ENDDO
+
+
+      IF( alphax.NE.0. )   THEN
+
+         DO  ij   = 1, iim
+          xpn(ij) = aire(   ij   ) * pps(  ij     )
+          xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+         ENDDO
+          tpn      = SSUM(iim,xpn,1)/apoln
+          tps      = SSUM(iim,xps,1)/apols
+
+         DO ij   = 1, 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
+
+      ENDIF
+
+
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/addit.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/addit.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/addit.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/adv_h2o.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/adv_h2o.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/adv_h2o.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/adv_hor.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/adv_hor.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/adv_hor.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/advect.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/advect.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/advect.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/advection.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/advection.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/advection.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/advertF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/advertF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/advertF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/amont.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/amont.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/amont.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/amont_qsat.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/amont_qsat.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/amont_qsat.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/angtot.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/angtot.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/angtot.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/angumom.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/angumom.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/angumom.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/bernoui.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/bernoui.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/bernoui.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/bin2grads.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/bin2grads.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/bin2grads.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/bin2grads56.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/bin2grads56.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/bin2grads56.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/cal_br.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/cal_br.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/cal_br.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/cal_br_st.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/cal_br_st.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/cal_br_st.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/calc_uvtq.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/calc_uvtq.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/calc_uvtq.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/caldyn.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/caldyn.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/caldyn.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/caldyn0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/caldyn0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/caldyn0.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/calfis.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/calfis.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/calfis.F	(revision 3)
@@ -0,0 +1,556 @@
+      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)
+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)
+
+      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.
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)
+               lonfi((j-2)*iim+1+i)= rlonv(i)
+     	    ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)
+         lonfi(ngridmx)= 0.
+         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)/apoln
+        ig0=2
+       DO j=2,jjm
+           DO i = 1, iim
+              pvervel(ig0,l) = pw(i,j,l) * unsaire(i,j)
+              ig0 = ig0 + 1
+           ENDDO
+       ENDDO
+        pvervel(ig0,l)=pw(1,jjp1,l)/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,  
+     ,             pcvgu, pcvgv, pcvgt, pcvgq, pvervel,
+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/branches/LF/libf/dyn3d/clesph0.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/clesph0.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/clesph0.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comav.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comav.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comav.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comconst.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comconst.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comconst.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comdiss.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comdiss.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comdiss.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comdissip.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comdissip.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comdissip.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comdissipn.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comdissipn.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comdissipn.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comdissnew.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comdissnew.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comdissnew.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comgeom.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comgeom.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comgeom.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comgeom2.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comgeom2.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comgeom2.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/comvert.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/comvert.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/comvert.h	(revision 3)
@@ -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(llmp1)
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+
+c-----------------------------------------------------------------------
Index: LMDZ.3.3/branches/LF/libf/dyn3d/control.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/control.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/control.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/convflu.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/convflu.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/convflu.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/convmas.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/convmas.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/convmas.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/coordij.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/coordij.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/coordij.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/covcont.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/covcont.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/covcont.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/covnat.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/covnat.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/covnat.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/cray.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/cray.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/cray.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/create_etat0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/create_etat0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/create_etat0.F	(revision 3)
@@ -0,0 +1,8 @@
+      PROGRAM create_etat0
+C
+C   Programme d'appel a etat0, creation des etats initiaux
+C   
+C
+      CALL etat0_netcdf
+      STOP
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/create_limit.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/create_limit.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/create_limit.F	(revision 3)
@@ -0,0 +1,778 @@
+      PROGRAM create_limit
+      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-------------------------------------------------------------
+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"
+c
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
+     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
+c-----------------------------------------------------------------------
+      REAL phy_nat(klon,360), phy_nat0(klon)
+      REAL phy_alb(klon,360)
+      REAL phy_sst(klon,360)
+      REAL phy_bil(klon,360)
+      REAL phy_rug(klon,360)
+      REAL phy_ice(klon,360)
+c
+      REAL masque(iip1,jjp1)
+      REAL mask(iim,jjp1)
+
+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)
+
+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
+
+      INTEGER i, j, k, l
+c Diverses variables locales
+      REAL time
+
+      INTEGER          longcles
+      PARAMETER      ( longcles = 20 )
+      REAL  clesphy0 ( longcles      )
+#include "serre.h"
+      INTEGER ncid,varid,ndimid(4),dimid
+      character*30 namedim
+
+c initialisations:
+      OPEN (8,file='run.def',form='formatted')
+      CALL defrun_new(8,.TRUE.,clesphy0)
+      CLOSE(8)
+
+      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(*,*) '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
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_msk)
+      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
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_msk)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+c
+      CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk,champ_msk,
+     .             iim, jjp1, rlonv, rlatu, champint)
+      CALL gr_int_dyn(champint, masque, iim, jjp1)
+      DO i = 1, iim
+         masque(i,1) = FLOAT(NINT(masque(i,1)))
+         masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
+      ENDDO
+      DO i = 1, iim
+      DO j = 1, jjp1
+         mask(i,j) = champint(i,j)
+      ENDDO
+      ENDDO
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
+      ierr = NF_CLOSE(ncid)
+c
+c
+C Traitement de la rugosite
+c
+      PRINT*, 'Traitement de la rugosite'
+      ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+
+      ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF
+      ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', imdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+      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
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+      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
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+         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
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+      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)
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+         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
+      DO k = 1, 360
+         CALL gr_dyn_fi(1, iip1, jjp1, klon,
+     .                  champan(1,1,k), phy_ice(1,k))
+         DO i = 1, klon
+            phy_nat(i,k) = phy_nat0(i)
+            IF ( (phy_ice(i,k) - 0.5).GE.1.e-5 ) THEN
+               IF (NINT(phy_nat0(i)).EQ.0) THEN
+                  phy_nat(i,k) = 3.0
+               ELSE
+                  phy_nat(i,k) = 2.0
+               ENDIF
+            ENDIF
+         ENDDO
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+      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)
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+         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
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlon)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      print*,'variable ', namedim, 'dimension ', jmdep
+      ierr = NF_INQ_VARID(ncid,namedim,dimid)
+      if (ierr.ne.0) then
+        print *, NF_STRERROR(ierr)
+        STOP
+      ENDIF 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,dlat)
+      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 
+      ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
+      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)
+         ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
+         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
+ccc      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
+      ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+      ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
+     .                        "Jour dans l annee")
+ccc      ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
+      ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+      ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
+     .                        "Nature du sol (0,1,2,3)")
+ccc      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+      ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+      ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
+     .                        "Temperature superficielle de la mer")
+ccc      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
+      ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+      ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
+     .                        "Reference flux de chaleur au sol")
+ccc      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
+      ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+      ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
+     .                        "Albedo a la surface")
+ccc      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
+      ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+      ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "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))
+      ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais,phy_nat(1,k))
+      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))
+      ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais,phy_nat(1,k))
+      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/branches/LF/libf/dyn3d/defrun.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/defrun.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/defrun.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/defrun_new.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/defrun_new.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/defrun_new.F	(revision 3)
@@ -0,0 +1,460 @@
+      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
+      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 ='run.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
+        PRINT *,' La valeur de clon passee par run.def est differente de 
+     *  celle lue sur le fichier  start '
+        STOP
+      ENDIF
+c
+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
+        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,*)    grossismxx
+      WRITE(tapeout,9001) ch1,'grossismx'
+      WRITE(tapeout,*)    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
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    grossismyy
+      WRITE(tapeout,9001) ch1,'grossismy'
+      WRITE(tapeout,*)    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
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    fxyhypbb
+      WRITE(tapeout,9001) ch1,'fxyhypbb'
+      WRITE(tapeout,*)    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
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomxx
+      WRITE(tapeout,9001) ch1,'dzoomx'
+      WRITE(tapeout,*)    dzoomxx
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        PRINT *,' La valeur de dzoomx passee par run.def est differente 
+     *  de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    dzoomyy
+      WRITE(tapeout,9001) ch1,'dzoomy'
+      WRITE(tapeout,*)    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
+      
+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
+              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
+      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
+        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
+      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
+c
+      READ (tapedef,9001) ch1,ch4
+      READ (tapedef,*)    ysinus
+      WRITE(tapeout,9001) ch1,'ysinus'
+      WRITE(tapeout,*)    ysinus
+       
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a12)
+cc
+      close(tapedef)
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/description.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/description.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/description.h	(revision 3)
@@ -0,0 +1,2 @@
+      character *120 descript
+      common /titre/descript
Index: LMDZ.3.3/branches/LF/libf/dyn3d/dh1.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dh1.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dh1.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/diagadv.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/diagadv.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/diagadv.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dissip.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dissip.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dissip.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/disvert.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/disvert.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/disvert.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/disvert0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/disvert0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/disvert0.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/diverg.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/diverg.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/diverg.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/diverg_gam.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/diverg_gam.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/diverg_gam.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/divergf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/divergf.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/divergf.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/divergst.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/divergst.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/divergst.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/divgrad.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/divgrad.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/divgrad.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/divgrad2.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/divgrad2.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/divgrad2.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dteta1.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dteta1.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dteta1.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dudv1.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dudv1.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dudv1.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dudv2.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dudv2.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dudv2.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dump2d.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dump2d.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dump2d.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dynetat0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dynetat0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dynetat0.F	(revision 3)
@@ -0,0 +1,381 @@
+      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_ini    = tab_cntrl(4)
+      anne_ini   = 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)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. 
+      ENDIF
+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/branches/LF/libf/dyn3d/dynhist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dynhist.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dynhist.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/dynredem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/dynredem.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/dynredem.F	(revision 3)
@@ -0,0 +1,585 @@
+      SUBROUTINE dynredem0(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
+      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
+c-----------------------------------------------------------------------
+      modname='dynredem'
+
+      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 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/branches/LF/libf/dyn3d/ener.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/ener.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/ener.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/enercin.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/enercin.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/enercin.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/etat0_netcdf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/etat0_netcdf.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/etat0_netcdf.F	(revision 3)
@@ -0,0 +1,357 @@
+      SUBROUTINE etat0_netcdf
+    
+      USE startvar
+      USE IOIPSL
+      !
+      IMPLICIT NONE
+      !
+#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"
+      !
+      REAL :: latfi(klon), lonfi(klon)
+      REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1),
+     . psol(iip1, jjp1), phis(iip1, jjp1)
+      REAL :: p3d(iip1, jjp1, llmp1)
+      REAL :: uvent(iip1, jjp1, llmp1)
+      REAL :: vvent(iip1, jjm, llmp1)
+      REAL :: t3d(iip1, jjp1, llmp1), tpot(iip1, jjp1, llmp1)
+      REAL :: q3d(iip1, jjp1, llmp1,nqmx), qsat(iip1, jjp1, llmp1)
+      REAL :: tsol(klon), qsol(klon), sn(klon), radsol(klon)
+      REAL :: deltat(klon), rugmer(klon), agesno(klon), zmea(klon)
+      REAL :: zstd(klon), zsig(klon), zgam(klon), zthe(klon)
+      REAL :: zpic(klon), zval(klon), rugsrel(klon)
+      REAL :: qd(iip1, jjp1, llmp1)
+      !
+      CHARACTER*80 :: varname
+      !
+      INTEGER :: i,j, ig, l
+      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 "clesph0.h"
+
+      INTEGER  ::        longcles
+      PARAMETER      ( longcles  = 20 )
+      REAL :: clesphy0 ( longcles       )
+      REAL :: p(iip1,jjp1,llmp1)
+      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,radpas,co2_ppm,solaire
+
+      CHARACTER*80 :: visu_file
+      INTEGER :: visuid
+      !
+      !   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()
+      !
+      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
+      !
+      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
+      rugo(:,:) = 0.0
+       CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0)
+      !
+      WRITE(*,*) 'MASQUE construit : Masque'
+      WRITE(*,'(49I1)') INT(masque(:,:))
+      !
+      !
+      varname = 'psol'
+      psol(:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0)
+      !
+      !  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)
+      phis = phis * 9.81
+      !
+      varname = 'u'
+      uvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls,
+     . workvar, uvent, 0.0)
+      !  
+      varname = 'v'
+      vvent(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls,
+     . workvar, vvent, 0.0)
+      !
+      varname = 't'
+      t3d(:,:,:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . workvar, t3d, 0.0)
+      !
+      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)
+      !
+      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
+      WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)),
+     .                           maxval(qsat(:,:,:))
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls,
+     . qsat, qd, 0.0)
+      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)
+      !
+      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)
+      !
+      varname = 'snow'
+      sn(:) = 0.0
+      CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0)
+      !
+      varname = 'rads'
+      radsol(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0)
+      !
+      varname = 'deltat'
+      deltat(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,deltat,0.0)
+      !
+      varname = 'rugmer'
+      rugmer(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0)
+      !
+      varname = 'agsno'
+      agesno(:) = 0.0
+      CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0)
+
+      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 Calcul intermediaire
+c 
+      CALL massdair( p3d, masse  )
+c
+
+      print *,' ALPHAX ',alphax
+
+      IF( alphax.NE.0. )   THEN
+       DO  l = 1, llm
+         DO  i    = 1, iim
+          xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+          xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+         ENDDO
+          xpn      = SUM(xppn)/apoln
+          xps      = SUM(xpps)/apols
+         DO i   = 1, iip1
+          masse(   i   ,   1     ,  l )   = xpn
+          masse(   i   ,   jjp1  ,  l )   = xps
+         ENDDO
+       ENDDO
+      ENDIF
+      q3d(iip1,:,:,:) = q3d(1,:,:,:)
+      phis(iip1,:) = phis(1,:)
+
+C Ecriture
+
+
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'sortie inidissip'
+      itau = 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
+      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,anneeref,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
+      phystep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (86400./phystep/ FLOAT(nbapp_rad) )
+      co2_ppm   = 330.0
+      solaire   = 1370.0
+
+      call physdem(lonfi, latfi, phystep,radpas,co2_ppm,
+     .                   solaire,tsol, qsol,
+     .                   sn, radsol, deltat, rugmer,
+     .                   agesno, zmea, zstd, zsig,
+     .                   zgam, zthe, zpic, zval,
+     .                   rugsrel)
+
+C     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/branches/LF/libf/dyn3d/exnerF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/exnerF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/exnerF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/exner_hyb.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/exner_hyb.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/exner_hyb.F	(revision 3)
@@ -0,0 +1,114 @@
+      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
+
+      IF( alphax.NE.0. )   THEN
+        DO  ij   = 1, iim
+         ppn(ij) = aire(   ij   ) * pks(  ij     )
+         pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+        ENDDO
+         xpn      = SSUM(iim,ppn,1) /apoln
+         xps      = SSUM(iim,pps,1) /apols
+
+        DO ij   = 1, iip1
+         pks(   ij     )  =  xpn
+         pks( ij+ip1jm )  =  xps
+        ENDDO
+      ENDIF
+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/branches/LF/libf/dyn3d/flumass.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/flumass.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/flumass.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/flumass3d.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/flumass3d.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/flumass3d.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/flumass_scal.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/flumass_scal.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/flumass_scal.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/fluxstoke.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fluxstoke.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fluxstoke.F	(revision 3)
@@ -0,0 +1,149 @@
+      SUBROUTINE fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "tracstoke.h"
+
+
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm)
+      REAL phis(ip1jmp1)
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm)
+
+      REAL pbarvst(iip1,jjp1,llm)
+
+
+      INTEGER iadvtr 
+      INTEGER ij,l,irec,i,j
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc,irec
+      SAVE phic,tetac
+      logical first
+      save first
+      data first/.true./
+      DATA iadvtr/0/
+
+      if(first) then
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
+#endif
+         open(47,file='fluxmass',form='unformatted',
+     s        access='direct',recl=4*(6*ijp1llm))
+         irec=1
+         first=.false.
+
+         open(77,file='fluxmass.ctl',status='unknown',form='formatted')
+
+      endif
+
+
+      IF(iadvtr.EQ.0) THEN
+         CALL initial0(ijp1llm,phic)
+         CALL initial0(ijp1llm,tetac)
+         CALL initial0(ijp1llm,pbaruc)
+         CALL initial0(ijmllm,pbarvc)
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+            tetac(ij,l) = tetac(ij,l) + teta(ij,l)
+            phic(ij,l) = phic(ij,l) + phi(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+      ENDIF
+
+      iadvtr   = iadvtr+1
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.istdyn ) THEN
+
+c    normalisation
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn)
+            tetac(ij,l) = tetac(ij,l)/float(istdyn)
+            phic(ij,l) = phic(ij,l)/float(istdyn)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn)
+         ENDDO
+      ENDDO
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+        do l=1,llm
+           do j=1,jjm
+              do i=1,iip1
+                 pbarvst(i,j,l)=pbarvg(i,j,l)
+              enddo
+           enddo
+           do i=1,iip1
+              pbarvst(i,jjp1,l)=0.
+           enddo
+        enddo
+
+         iadvtr=0
+
+         irec=irec+1
+         write(47,rec=1) float(irec),dtvr,float(istdyn),
+     s    float(iim),float(jjm),float(llm),rlonu,rlonv,rlatu,rlatv
+     s    ,aire,phis
+         write(47,rec=irec) massem,pbarug,pbarvst,wg,tetac,phic
+
+c   on reinitialise a zero les flux de masse cumules.
+
+      write(77,'(a4,2x,a40)')
+     &       'DSET ','^fluxmass'
+
+      write(77,'(a12)') 'UNDEF 1.0E30'
+      write(77,'(a5,1x,a40)') 'TITLE ','Titre a voir'
+      call formcoord(77,iip1,rlonv,180./pi,.false.,'XDEF')
+      call formcoord(77,jjp1,rlatu,180./pi,.true.,'YDEF')
+      call formcoord(77,llm,presnivs,1.,.false.,'ZDEF')
+      write(77,'(a4,i10,a30)')
+     &       'TDEF ',irec,' LINEAR 02JAN1987 1DY '
+      write(77,'(a4,2x,i5)') 'VARS',6
+      write(77,1000) 'masse',llm,99,'masse    '
+      write(77,1000) 'pbaru',llm,99,'pbaru    '
+      write(77,1000) 'pbarv',llm,99,'pbarv    '
+      write(77,1000) 'w    ',llm,99,'w        '
+      write(77,1000) 'teta ',llm,99,'teta     '
+      write(77,1000) 'phi  ',llm,99,'phi      '
+      write(77,'(a7)') 'ENDVARS'
+
+1000  format(a5,3x,i4,i3,1x,a39)
+
+
+
+      ENDIF ! if iadvtr.EQ.istdyn
+
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/fxhyp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxhyp.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fxhyp.F	(revision 3)
@@ -0,0 +1,353 @@
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025)
+
+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 transition ,   normalement  = 1  .
+c
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 50000, nmax2 = 2*nmax )
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzoom,tau,grossism
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c    ......   arguments  de  sortie  ......
+c
+       REAL xlon(iip1),xprimm(iip1),xuv
+       REAL xtild(0:nmax2)
+       REAL fhyp(0:nmax),ffdx(0:nmax),beta,Xprimt(0:nmax2)
+       REAL Xf(0:nmax2),xxpr(0:nmax2)
+       REAL xvrai(iip1),xxprim(iip1) 
+       REAL pi,depi,epsilon,xzoom
+       INTEGER i,it,ik,iter,ii,idif
+       REAL xi,xo1,xint,xmoy,xlon2,fxm,Xprimin
+       REAL champmin,champmax
+       INTEGER is2
+       SAVE is2
+       REAL dlon1(iip1),dlon2(iip1),dlon3(iip1)
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-6
+       xzoom    = xzoomdeg * pi/180. 
+
+
+
+       DO i = 0, nmax2 
+         xtild(i) = FLOAT(i) /nmax2
+        IF( xtild(i).EQ. 0.5 )  xtild(i) = xtild(i) + 1.e-6
+       ENDDO
+
+       DO i = 1, nmax
+        fhyp(i) = TANH ( ( xtild(i) - 0.5*(1.- dzoom) )          /
+     ,                 ( tau * xtild(i) * ( 0.5 -xtild(i))) )
+       ENDDO
+
+        fhyp(   0  ) = - 1.
+        fhyp( nmax ) =   1.
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdx( 0 ) = 0.
+
+       DO i = 1, nmax
+        xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+        fxm     = TANH ( ( xmoy - 0.5 * ( 1. - dzoom ) )    /
+     ,                 ( tau * xmoy * ( 0.5 -xmoy)) )
+        ffdx(i) = ffdx(i-1) + fxm * ( xtild(i) - xtild(i-1) )
+       ENDDO
+
+        beta  = ( grossism * ffdx(nmax) - 0.5 ) / ( ffdx(nmax) - 0.5 )
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = 0, nmax
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i = 0, nmax
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+        Xf(0) = 0.
+       DO i = 1, nmax
+        xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+        fxm     = TANH ( ( xmoy - 0.5 * ( 1. - dzoom ) )    /
+     ,                 ( tau * xmoy * ( 0.5 -xmoy)) )
+        xxpr(i)    = beta + ( grossism - beta ) * fxm
+       ENDDO
+
+       DO i = 1,nmax
+         xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+        do i=1,nmax2
+        xf(i)=xf(i)/xf(nmax2)
+        enddo
+
+
+       PRINT *,' XF ',xf(0),xf(nmax),xf(nmax2)
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+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.5
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+
+      DO 1500 i = 1, iim
+
+      xlon2 = (  FLOAT(i) + xuv - 0.75) / FLOAT(iim) 
+
+      xo1   = 0.
+      xi    = xlon2
+c
+      DO 500 iter = 1,300
+
+      DO 250 it =  nmax2,0,-1
+      IF( xi.GE.xtild(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+      xi = xtild(it)
+
+350   CONTINUE
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        xf(it+1) = 1.
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  xi(it) et xi(it+1)   pour avoir X(xi)  
+c      .....           et   X'(xi)                             .....
+c  .................................................................
+
+       xint   = ( Xf(it+1)-Xf(it) ) / ( xtild(it+1)-xtild(it) )      * 
+     +                    ( xi-xtild(it) )  +  Xf(it)
+      Xprimin = ( Xprimt(it+1)-Xprimt(it) )/ ( xtild(it+1)-xtild(it) ) *
+     +                    ( xi-xtild(it) )  +  Xprimt(it)
+
+       xi = xi - (xint-xlon2)/Xprimin
+
+      IF( ABS(xi-xo1).LE.epsilon) GO TO 550
+      xo1 = xi
+c
+500   CONTINUE
+      PRINT *,' ***   PAS DE SOLUTION  ****  ',i,xlon2
+        STOP 4
+550   CONTINUE
+
+       xxprim(i)   = depi/( FLOAT(iim) * Xprimin)
+       xvrai(i)    = depi *  (xi - 0.5) + xzoom
+
+
+1500   CONTINUE
+
+       DO i = 1 , iim
+        xlon  (i)   = xvrai(i)
+        xprimm(i)   = xxprim(i)
+cc        xxlon(i) = xlon(i)*180./pi
+       ENDDO
+        
+cc      PRINT *,' XLON avant '
+cc      PRINT 68,(xxlon(i),i=1,iim)
+       
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         PRINT *,' PBS.  avec  rlonu(',i+1,' plus petit que rlonu(',i,
+     ,   ')'
+         STOP
+        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
+
+       PRINT *,' LONGITUDES  min max ',champmin,champmax
+
+      IF(champmin .GE. - pi .AND. champmax.LE. pi )  THEN
+                GO TO 1600
+      ELSE
+        PRINT 18
+        PRINT *,'Reorganisation des longitudes pour avoir entre - pi ',
+     ,  ' et  pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            PRINT *, ' PBS. 1 '
+            STOP
+ 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
+             PRINT *,' PBS.  2 '
+              STOP
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+cc           PRINT *,' IS2 ',is2
+           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
+         PRINT *, ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+         PRINT 18
+         PRINT 68,xvrai
+         PRINT *,' XPRIM '
+         PRINT 68, xprimm
+           DO i = 1,iim + 1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.2 )  THEN
+         PRINT 18
+         PRINT *, ' XLON aux pts. V   apres ( en  deg. ) '
+         PRINT 68,xvrai
+         PRINT *,' XPRIM '
+         PRINT 68, xprimm
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.3 )  THEN
+         PRINT 18
+         PRINT *, ' XLON aux pts. U   apres ( en  deg. ) '
+         PRINT 68,xvrai
+         PRINT *,' XPRIM '
+         PRINT 68, xprimm
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+         ELSE IF( ik.EQ.4 )  THEN
+         PRINT 18
+         PRINT *, ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+         PRINT 68,xvrai
+         PRINT *,' XPRIM '
+         PRINT 68, xprimm
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+         ENDIF
+
+5000    CONTINUE
+c
+c       ...........  fin  de la boucle  do 5000      ............
+
+c
+        DO i = 1, iim + 1
+         dlon1(i) = rlonm025(i) - rlonv(i)
+         dlon2(i) = rlonm025(i) - rlonp025(i)
+         dlon3(i) = rlonm025(i) - rlonu(i)
+        ENDDO
+
+        DO i = 1, iim + 1
+         rlonm025(i) = rlonm025(i) + dlon1(i)
+        ENDDO
+
+        DO i = 1, iim + 1
+         rlonv(i)    = rlonm025(i) - dlon1(i)
+         rlonp025(i) = rlonm025(i) - dlon2(i)
+         rlonu(i)    = rlonm025(i) - dlon3(i)
+        ENDDO
+
+        DO i = 1, iim
+         xprimu   (i) = rlonu(i+1) - rlonu(i)
+         xprimv   (i) = rlonv(i+1) - rlonv(i)
+         xprimm025(i) = rlonm025(i+1) - rlonm025(i)
+         xprimp025(i) = rlonp025(i+1) - rlonp025(i)
+        ENDDO
+         xprimu   (iip1) = xprimu   (1)
+         xprimv   (iip1) = xprimv   (1)
+         xprimm025(iip1) = xprimm025(1)
+         xprimp025(iip1) = xprimp025(1)
+
+
+18       FORMAT(/)
+68       FORMAT(1x,7f9.2)
+
+
+         RETURN
+         END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/fxy.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxy.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fxy.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/fxyhypF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxyhypF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fxyhypF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/fxyhyper.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxyhyper.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fxyhyper.F	(revision 3)
@@ -0,0 +1,117 @@
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy,deltay  , 
+     ,                      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       du zoom  :   tau   , ici  =  1.
+c
+c     N.B :   le produit ( grossissement * extension )  doit etre <  1.
+c    *******
+c     En plus , il y a un autre parametre , moins important mais quand
+c     meme utile , c'est  deltay , deplacement de la zone du zoom en
+c     latitude   :  Si  on deplace  de 10. degres vers le nord  ( deltay
+c      = 10.  dans inigeom ) .
+c
+c
+#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 deltay
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy, deltay , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 )
+
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 )
+
+
+        DO i = 1, iim
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           PRINT *,' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           PRINT *,' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           PRINT *,' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        PRINT *,'  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+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 *,' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        PRINT *,' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        PRINT *,' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        PRINT *,'Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       PRINT *,'  *** TEST DE COHERENCE  OK    POUR   FY **** '
+
+c
+
+       RETURN
+       END
+
Index: LMDZ.3.3/branches/LF/libf/dyn3d/fxysinus.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fxysinus.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fxysinus.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/fyhyp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/fyhyp.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/fyhyp.F	(revision 3)
@@ -0,0 +1,312 @@
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzoom,tau,deltay ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ) 
+
+
+       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
+c     tau  la transition ,   normalement  = 1  .
+
+c  N.B :  on doit avoir :  grossism * dzoom  <   1 .
+c         **************
+c
+c    Pour Indoex , on a pris :
+c         *******
+c    grossism = 2.5 , dzoom = 7/24  en x et  y  , pour iim = 128 et jjm=64
+c    yzoomdeg = 0.  , tau = 1.  et delaty = 10.
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 50000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzoom,tau , deltay
+
+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 ylat(jjp1), yprim(jjp1)
+       REAL yuv
+       REAL ytild(0:nmax2)
+       REAL fhyp(0:nmax),ffdx(0:nmax),beta,Ytprim(0:nmax2)
+       SAVE Ytprim, ytild,Yf
+       REAL Yf(0:nmax2),yypr(0:nmax2)
+       REAL yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL pi,depi,pis2,epsilon,yzoom
+       REAL yo1,yi,ylon2,fxm,ymoy,yint,Yprimin
+       REAL ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       epsilon  = 1.e-6
+       yzoom    = yzoomdeg * pi/180. 
+
+
+
+       DO i = 0, nmax2 
+        ytild(i) = FLOAT(i) /nmax2
+       IF( ytild(i).EQ.0.5 )  ytild(i) = ytild(i) + 1.e-6
+       ENDDO
+
+       DO i = 1, nmax
+        fhyp(i) = TANH ( ( ytild(i) - 0.5*(1.- dzoom) )          /
+     ,                 ( tau * ytild(i) * ( 0.5 -ytild(i))) )
+       ENDDO
+
+       fhyp(   0  ) = - 1.
+       fhyp( nmax ) =   1.
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdx( 0 ) = 0.
+
+       DO i = 1, nmax
+        ymoy    = 0.5 * ( ytild(i-1) + ytild( i ) )
+        fxm     = TANH ( ( ymoy - 0.5 * ( 1. - dzoom ) )    /
+     ,                 ( tau * ymoy * ( 0.5 -ymoy)) )
+        ffdx(i) = ffdx(i-1) + fxm * ( ytild(i) - ytild(i-1) )
+       ENDDO
+
+        beta  = ( grossism * ffdx(nmax) - 0.5 ) / ( ffdx(nmax) - 0.5 )
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i = 0, nmax
+        Ytprim( nmax2 - i ) = Ytprim( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Yf     ........
+
+        Yf(0) = 0.
+       DO i = 1, nmax
+        ymoy    = 0.5 * ( ytild(i-1) + ytild( i ) )
+        fxm     = TANH ( ( ymoy - 0.5 * ( 1. - dzoom ) )    /
+     ,                 ( tau * ymoy * ( 0.5 -ymoy)) )
+        yypr(i)    = beta + ( grossism - beta ) * fxm
+       ENDDO
+
+       DO i = 1,nmax
+         yypr(nmax2-i+1) = yypr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Yf(i)   = Yf(i-1) + yypr(i) * ( ytild(i) - ytild(i-1) )
+        ENDDO
+c
+c
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+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
+       DO 1500 j =  1,jlat
+
+        ylon2 =  ( FLOAT(j)  + yuv  -1.) / FLOAT(jjm) 
+
+        yo1   = 0.
+        yi    = ylon2
+
+c
+       DO 500 iter = 1,300
+
+       DO 250 it =  nmax2,0,-1
+        IF( yi.GE.ytild(it))  GO TO 350
+250    CONTINUE
+
+       it = 0
+       yi = ytild(it)
+
+350    CONTINUE
+
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = 1.
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       yint   = ( Yf(it+1)-Yf(it) ) / ( ytild(it+1)-ytild(it) )      * 
+     +                    ( yi-ytild(it) )  +  Yf(it)
+      Yprimin = ( Ytprim(it+1)-Ytprim(it) )/ ( ytild(it+1)-ytild(it) ) *
+     +                    ( yi-ytild(it) )  +  Ytprim(it)
+       yi = yi - (yint-ylon2)/Yprimin
+
+      IF( ABS(yi-yo1).LE.epsilon) GO TO 550
+      yo1 = yi
+c
+500   CONTINUE
+      PRINT *,' ***   PAS DE SOLUTION  ****  ',j,ylon2,iter
+        STOP 4
+550   CONTINUE
+
+       yprim(j)    = pi /( FLOAT(jjm) *  Yprimin)
+       yvrai(j)    = pi *  (yi - 0.5) + yzoom
+
+1500    CONTINUE
+
+cc          print *,' LAT avant reorgan '
+cc         print 68,(yyvrai(j),j=1,jlat)
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         PRINT *,' PBS.  avec  rlat(',j+1,' plus petit que rlat(',j,
+     ,   ')'
+         STOP
+        ENDIF
+       ENDDO
+
+        PRINT 18
+        PRINT *,'Reorganisation des latitudes pour avoir entre - pi/2 ',
+     ,  ' et  pi/2 '
+c
+           
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 - deltay * pi/180.
+          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
+        PRINT 18
+        PRINT *, ' YLAT  en U   apres ( en  deg. ) '
+        PRINT 68,(yvrai(j),j=1,jlat)
+        PRINT *,' YPRIM '
+        PRINT 68,( yprim(j),j=1,jlat)
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+c
+        ELSE IF ( ik.EQ. 2 )  THEN
+        PRINT 18
+        PRINT *, ' YLAT   en V  apres ( en  deg. ) '
+        PRINT 68,(yvrai(j),j=1,jlat)
+        PRINT *,' YPRIM '
+        PRINT 68,( yprim(j),j=1,jlat)
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+c
+        ELSE IF ( ik.EQ. 3 )  THEN
+        PRINT 18
+        PRINT *, ' YLAT  en U + 0.75  apres ( en  deg. ) '
+        PRINT 68,(yvrai(j),j=1,jlat)
+        PRINT *,' YPRIM '
+        PRINT 68,( yprim(j),j=1,jlat)
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+        PRINT 18
+        PRINT *, ' YLAT en U + 0.25  apres ( en  deg. ) '
+        PRINT 68,(yvrai(j),j=1,jlat)
+        PRINT *,' YPRIM '
+        PRINT 68,( yprim(j),j=1,jlat)
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+        ENDIF
+
+5000   CONTINUE
+c
+c  .....     fin de la boucle  do 5000 .....
+
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/gcm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gcm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gcm.F	(revision 3)
@@ -0,0 +1,629 @@
+
+      PROGRAM gcm
+
+      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"
+
+
+      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 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)
+
+      LOGICAL offline  ! Controle du stockage ds "fluxmass"
+      PARAMETER (offline=.false.)
+
+      character*80 dynhist_file, dynhistave_file
+      character*20 modname
+      character*80 abort_message
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      modname = 'gcm'
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+      dynhist_file = 'dyn_hist.nc'
+      dynhistave_file = 'dyn_hist_ave.nc'
+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 
+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
+      DO  iq = 1, 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).LE.0.OR.iadv(iq).GT.3 )   THEN
+       PRINT *,' Erreur dans le  choix de  iadv . Corriger et repasser
+     * . '
+         STOP 
+       ENDIF
+      ENDDO
+c
+      first = .TRUE.
+      numvanle = nqmx + 1
+      DO  iq = 1, nqmx
+        IF( iadv(iq).EQ.3.AND.first ) THEN
+          numvanle = iq
+          first    = .FALSE.
+        ENDIF
+      ENDDO
+c
+      DO  iq = 1, nqmx
+        IF( iadv(iq).NE.3.AND.iq.GT.numvanle )   THEN
+          PRINT *,' Il y a discontinuite dans le choix du shema de ',
+     *    'Van-leer pour les traceurs . Corriger et repasser . '
+           STOP
+        ENDIF
+        IF( iadv(iq).LT.1.OR.iadv(iq).GT.3 )    THEN
+          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')
+      CALL defrun_new( 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
+
+      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,anne_ini,phis,nqmx)
+
+      ecripar = .TRUE.
+
+      time_step = zdtvr
+      t_ops = iecri * daysec
+      t_wrt = iecri * daysec
+      CALL inithist(dynhist_file,day_ini,anne_ini,time_step,
+     .              t_ops, t_wrt, nqmx, histid, histvid)
+
+      t_ops = iperiod * time_step
+      t_wrt = periodav * daysec
+      CALL initdynav(dynhistave_file,day_ini,anne_ini,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
+c     call nudge(itau,ucov,vcov,teta,masse,ps)
+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                  )
+c
+         ENDIF
+c
+ 15     CONTINUE
+C
+         IF (offline) THEN
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+           CALL fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
+         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
+        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
+       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
+
+         CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dhdis)
+
+         CALL addit( ijp1llm,ucov ,dudis,ucov )
+         CALL addit( ijmllm ,vcov ,dvdis,vcov )
+         CALL addit( ijp1llm,teta ,dhdis,teta )
+
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+      IF( alphax.NE. 0. ) THEN
+
+        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
+
+      ENDIF
+
+      END IF
+        
+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)
+            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        )
+       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+     ,                          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)
+
+            ENDIF
+
+               IF(MOD(itau,iecri*day_step).EQ.0) THEN
+                  nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi       )
+       CALL writehist( histid, histvid, nqmx, itau,vcov , 
+     ,                          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/branches/LF/libf/dyn3d/gcmtest.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gcmtest.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gcmtest.F	(revision 3)
@@ -0,0 +1,656 @@
+
+      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   ...  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"
+
+      INTEGER nid
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_latv
+      INTEGER idim_s, idim_sig, idim_tim
+
+      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 inigeom
+      EXTERNAL exner_hyb,addit
+      EXTERNAL defrun_new, test_period
+      REAL  SSUM
+      REAL time_0 , finvmaold(ip1jmp1,llm)
+
+      LOGICAL lafin
+      INTEGER ij,iq,j,i,l,numvanle,iapp_tracvl
+
+
+      integer histid, histvid, histaveid
+      real time_step, t_wrt, t_ops
+      integer itime_step
+      character*80 dynhist_file, dynhistave_file
+
+
+      REAL rdayvrai,rdaym_ini,rday_ecri
+      LOGICAL first
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+CMAF pour rajout injection
+      real lon_stat,lat_stat
+      integer i_stat,j_stat
+      LOGICAL injecte
+      DATA injecte/.true./
+      integer ijstat
+CMAF
+cAA
+      character*10 file
+cAA
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      descript = 'Run GCM LMDZ'
+      lafin    = .FALSE.
+
+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 
+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
+      DO  iq = 1, 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).LE.0.OR.iadv(iq).GT.3 )   THEN
+       PRINT *,' Erreur dans le  choix de  iadv . Corriger et repasser
+     * . '
+         STOP 
+       ENDIF
+      ENDDO
+c
+      first = .TRUE.
+      numvanle = nqmx + 1
+      DO  iq = 1, nqmx
+        IF( iadv(iq).EQ.3.AND.first ) THEN
+          numvanle = iq
+          first    = .FALSE.
+        ENDIF
+      ENDDO
+c
+      DO  iq = 1, nqmx
+        IF( iadv(iq).NE.3.AND.iq.GT.numvanle )   THEN
+          PRINT *,' Il y a discontinuite dans le choix du shema de ',
+     *    'Van-leer pour les traceurs . Corriger et repasser . '
+           STOP
+        ENDIF
+        IF( iadv(iq).LT.1.OR.iadv(iq).GT.3 )    THEN
+          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)
+
+      OPEN( 99,file ='run.def',status='old',form='formatted')
+      CALL defrun_new( 99, .TRUE. , clesphy0 )
+      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
+
+      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,anne_ini,phis,nqmx)
+      CALL dynhist0("histoire.nc",day_ini,anne_ini,phis,nqmx)
+
+      ecripar = .TRUE.
+
+      dtav = iperiod*dtvr/daysec
+      dynhistave_file = 'histmoy.nc'
+      t_ops = iperiod*dtvr
+      t_wrt = periodav * daysec
+      CALL initdynav(dynhistave_file,day_ini,anne_ini,dtvr,
+     .              t_ops, t_wrt, nqmx, histaveid)
+
+
+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
+c
+      IF( MOD( itau, 10* day_step ).EQ.0 )  THEN
+         CALL  test_period ( ucov,vcov,teta,q,p,phis )
+         PRINT *,' ----   Test_period   OK ! -----', itau
+      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
+        if (injecte) then
+            injecte=.false.
+c On injecte tous les traceurs de la meme facon
+C injection au debut de la simulation
+C !! MAF dans code pi en radians et lat lon en degrees => conversion
+C injection au point -2, 48 en lat lon
+            lon_stat= -2.
+            lat_stat= 48.
+C
+            pi=2.*asin(1.)
+            lon_stat=lon_stat*pi/180.
+            lat_stat=lat_stat*pi/180.
+            CALL coordij(lon_stat,lat_stat,i_stat,j_stat)
+
+            print*,'INJECTION AU POINT ',lon_stat,lat_stat
+     s      ,'     I,J=',i_stat,j_stat,jjp1-j_stat+1
+            ijstat=(j_stat-1)*iip1+i_stat
+C cas avec rnpb on commence a injecter pour le traceur 5
+            do iq=5,nqmx
+               q(ijstat,1,iq)=
+     s         +1.e12/masse(ijstat,1)
+            enddo
+        endif
+
+        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                  )
+c
+         ENDIF
+c
+ 15     CONTINUE
+C
+Cmaf stokage du flux de masse pour traceurs OFF-LINE
+          CALL fluxstoke(pbaru,pbarv,masse,teta,phi,phis)
+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 MAF le dernier traceur ne passe pas dans la physique 
+C nqmx => nqmx -1 dans calfis et addfi
+C
+        CALL calfis( nqmx-1, 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-1, dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps ,
+     $                 dufi, dvfi, dhfi , dqfi ,dpfi  )
+c
+       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
+
+         CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dhdis)
+
+         CALL addit( ijp1llm,ucov ,dudis,ucov )
+         CALL addit( ijmllm ,vcov ,dvdis,vcov )
+         CALL addit( ijp1llm,teta ,dhdis,teta )
+
+
+c    .......        P. Le Van (  ajout  le 17/04/96  )   ...........
+c   ...      Calcul de la valeur moyenne, unique de h aux poles  .....
+c
+      IF( alphax.NE. 0. ) THEN
+
+        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
+
+      ENDIF
+
+      END IF
+        
+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
+
+
+C            IF( itau. EQ. itaufinp1 )    STOP
+            IF( itau. EQ. itaufinp1 )    goto 200
+
+
+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)
+
+            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        )
+       CALL dynhist1("histoire.nc",time+iday-day_ini,
+     .                     vcov,ucov,teta,q,nqmx,masse,ps)
+
+
+            ENDIF
+
+            IF(itau.EQ.itaufin) THEN
+
+       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.
+C            IF( itau. EQ. itaufinp1 )    STOP
+            IF( itau. EQ. itaufinp1 )    goto 200
+
+               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)
+
+            ENDIF
+
+               IF(MOD(itau,iecri*day_step).EQ.0) THEN
+                  nbetat = nbetatdem
+       CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi       )
+      CALL dynhist1("histoire.nc",time+iday-day_ini,
+     .                     vcov,ucov,teta,q,nqmx,masse,ps)
+
+               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
+
+ 200  continue
+      call histclo
+
+
+ 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/branches/LF/libf/dyn3d/geopot.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/geopot.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/geopot.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gr_dyn_fi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gr_dyn_fi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gr_dyn_fi.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gr_fi_dyn.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gr_fi_dyn.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gr_fi_dyn.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gr_int_dyn.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gr_int_dyn.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gr_int_dyn.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gr_u_scal.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gr_u_scal.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gr_u_scal.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gr_v_scal.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gr_v_scal.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gr_v_scal.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/grad.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/grad.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/grad.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gradiv.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gradiv.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gradiv.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gradiv2.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gradiv2.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gradiv2.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/gradsdef.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/gradsdef.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/gradsdef.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/grid_atob.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/grid_atob.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/grid_atob.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/grid_noro.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/grid_noro.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/grid_noro.F	(revision 3)
@@ -0,0 +1,481 @@
+
+      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)
+#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)
+      integer mask(imar+1,jmar)
+      real num_tot(2200,1100),num_lan(2200,1100)
+c
+      REAL a(2200),b(2200),c(1100),d(1100)
+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  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
+           if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then
+             mask(ii,jj)=1
+           else
+             mask(ii,jj)=0
+           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)
+
+       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: 
+           zsig(ii,jj)=sqrt(xq)*mask(ii,jj)
+c isotropy:
+           zgam(ii,jj)=xp/xq*mask(ii,jj)
+c angle theta:
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj)
+           zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+           zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj)
+           zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj)
+           zval(ii,jj)=zval(ii,jj)*mask(ii,jj)
+           zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj)
+
+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)
+      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 weight(-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
+      WEIGHT(IS,JS)=1./FLOAT((1+IS**2)*(1+JS**2))
+      SUM=SUM+WEIGHT(IS,JS)
+      ENDDO
+      ENDDO
+
+      DO IS=-1,1
+      DO JS=-1,1
+      WEIGHT(IS,JS)=WEIGHT(IS,JS)/SUM
+      ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+      DO I=2,IMAR-1
+      XF(I,J)=0.
+      DO IS=-1,1
+      DO JS=-1,1
+         XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHT(IS,JS)
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDDO
+
+      DO J=2,JMAR-1
+         XF(1,J)=0.
+      IS=IMAR-1
+      DO JS=-1,1 
+         XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHT(-1,JS)
+      ENDDO
+      DO IS=0,1 
+      DO JS=-1,1 
+         XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHT(IS,JS)
+      ENDDO
+      ENDDO
+         XF(IMAR,J)=XF(1,J)
+      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/branches/LF/libf/dyn3d/groupe.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/groupe.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/groupe.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/groupeun.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/groupeun.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/groupeun.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/iniav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/iniav.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/iniav.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/inicons0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inicons0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/inicons0.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/iniconst.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/iniconst.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/iniconst.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/inidissip.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inidissip.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/inidissip.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/inigeom.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inigeom.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/inigeom.F	(revision 3)
@@ -0,0 +1,696 @@
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c    .....................
+c
+c   ............      Version  du 20/12/98     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+      REAL        deltay, tauy, taux
+      PARAMETER ( deltay =  0. , tauy = 1. , taux = 1. )
+c
+c     deltay  est ( en degres ) le deplacement eventuel en Y du zoom
+cc    taux  et  tauy  sont  les raideurs   du  zoom
+c
+c
+#include "dimensions.h"
+#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
+
+
+
+c----------------------------------------------------------------------
+      REAL      SSUM
+      EXTERNAL  SSUM
+c
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+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
+      PRINT 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
+
+      PRINT *,' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      PRINT 990
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        PRINT *,' ***  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
+        PRINT *,' *** 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   .....................................................................
+
+       PRINT *,'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy, deltay  ,
+     ,               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)
+cc       yprp             = fyprim( FLOAT(j) - 0.25 )
+cc       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  )
+c         rlatp    = fy    ( FLOAT(j) - 0.25 )
+c         yprp     = fyprim( FLOAT(j) - 0.25 )
+c         rlatm    = fy    ( FLOAT(j) + 0.25 )
+c         yprm     = fyprim( FLOAT(j) + 0.25 )
+
+         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   ....  Modif  P. Le Van  ( 4/07/96 )  .....
+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
+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
+       PRINT *,' INIGEOM  RLONV '
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       PRINT 400,rlonvv
+c
+       PRINT *,' RLATV '
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       PRINT 400,(rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       PRINT *,' RLONU '
+       PRINT 400,rlonvv
+c
+       PRINT *,' RLATU '
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       PRINT 400,(rlatuu(i),i=1,jjp1)
+c
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+c
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/inigrads.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inigrads.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/inigrads.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/iniinterp_horizFF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/iniinterp_horizFF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/iniinterp_horizFF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/inirappelF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/inirappelF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/inirappelF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/initial0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/initial0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/initial0.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/integrd.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/integrd.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/integrd.F	(revision 3)
@@ -0,0 +1,237 @@
+      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
+      IF( alphax.NE.0. )   THEN
+        DO  ij    = 1, iim
+         tppn(ij) = aire(   ij   ) * ps(  ij    )
+         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
+        ENDDO
+         tpn      = SSUM(iim,tppn,1)/apoln
+         tps      = SSUM(iim,tpps,1)/apols
+        DO ij   = 1, iip1
+         ps(   ij   )  = tpn
+         ps(ij+ip1jm)  = tps
+        ENDDO
+      ENDIF
+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
+      IF( alphax.NE.0. )   THEN
+        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
+      ENDIF
+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
+      IF( alphax.NE.0. )   THEN
+
+        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
+
+      ENDIF
+
+         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/branches/LF/libf/dyn3d/interp_horizFF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/interp_horizFF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/interp_horizFF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/interp_vert.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/interp_vert.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/interp_vert.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/juldate.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/juldate.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/juldate.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/laplacien.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/laplacien.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/laplacien.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/laplacien_gam.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_gam.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_gam.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/laplacien_rot.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_rot.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_rot.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/laplacien_rotgam.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_rotgam.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/laplacien_rotgam.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/lectflux.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/lectflux.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/lectflux.F	(revision 3)
@@ -0,0 +1,233 @@
+      SUBROUTINE lectflux(irec,massem,pbarun,pbarvn,wn,tetan,phin,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phis)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+#include "tracstoke.h"
+
+      integer irec,nrec,i,j
+
+      integer ngridmx,ig,l
+      parameter (ngridmx=iim*(jjm-1)+2)
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+
+      real zmfd(ngridmx,llm),zde_d(ngridmx,llm),zen_d(ngridmx,llm)
+      real zmfu(ngridmx,llm),zde_u(ngridmx,llm),zen_u(ngridmx,llm)
+      real coefkz(ngridmx,llm)
+      real frac_impa(ngridmx,llm),frac_nucl(ngridmx,llm)
+      real yu1(ngridmx), yv1(ngridmx)
+      real ftsol(ngridmx,nbsrf),pctsrf(ngridmx,nbsrf)
+      integer imfu,imfd,ien_u,ide_u,
+     s      ien_d,ide_d,
+     s      icoefkz,izu1,izv1,
+     s      itsol,ipsf,
+     s      ilei, ilec
+      parameter(imfu=1,imfd=llm+1,ien_u=2*llm+1,ide_u=3*llm+1,
+     s      ien_d=4*llm+1,ide_d=5*llm+1,
+     s      icoefkz=6*llm+1,
+     s      ilei=7*llm+1,ilec=8*llm+1,
+     s      izu1=9*llm+1,izv1=9*llm+2,
+     s      itsol=9*llm+3,ipsf=9*llm+3+nbsrf)
+      logical avant
+
+      real massefi(ngridmx,llm)
+
+      real massem(ip1jmp1,llm),tetan(ip1jmp1,llm)
+      real pbarun(iip1,jjp1,llm),pbarvn(iip1,jjm,llm)
+      real pbarvst(iip1,jjp1,llm)
+      real wn(iip1,jjp1,llm),phin(iip1,jjp1,llm)
+      real phis(iip1,jjp1)
+
+      real airefi(ngridmx)
+
+      real xlecn(ngridmx,9*llm+2+2*nbsrf)
+
+      real zcontrole(ngridmx),zmass,tmpdyn(iip1,jjp1),zflux
+
+      real ziadvtrac,zrec,ziadvtrac2,zrec2
+      real zim,zjm,zlm,zklon,zklev
+
+      real zpi
+
+      zpi=2.*asin(1.)
+
+
+c==================================================================
+c   Si le numero du record est 0 alors: INITIALISATION
+c==================================================================
+c
+      print*,'ENTREE DANS LECTFLUX'
+        print*,'IREC=',IREC
+      if(irec.eq.0) then
+
+        print*,'IREC==',0
+
+C test         call inigeom
+
+c==================================================================
+c   ouverture des fichiers
+c==================================================================
+
+c   Fichier fluxmass
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
+#endif
+      open(47,file='fluxmass',form='unformatted',
+     s     access='direct'
+     s     ,recl=4*(6*ijp1llm))
+      read(47,rec=1) zrec,dtvr,ziadvtrac,zim,zjm,zlm,
+     s   rlonu,rlonv,rlatu,rlatv,aire
+     s    ,phis
+      print*,'zrec,dtvr,ziadvtrac,zim,zjm,zlm'
+      print*,zrec,dtvr,ziadvtrac,zim,zjm,zlm
+      print*,rlonv
+
+
+
+c  Fichier physique
+c  Fichier lessivage (supprime les donnees utiles sont dans "physique")
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:physique")
+#endif
+      open(49,file='physique',form='unformatted',
+     s     access='direct'
+     s     ,recl=4*ngridmx*(9*llm+2+2*nbsrf))
+      read(49,rec=1) zrec2,ziadvtrac2,zklon,zklev
+      print*,'Entete du fichier physique'
+      print*,zrec2,ziadvtrac2,zklon,zklev
+
+      nrec=zrec
+      print*,'nrec=',nrec
+
+      istdyn=ziadvtrac
+      istphy=ziadvtrac2
+
+c==================================================================
+c   Fin des initialisations
+      else ! irec=0
+c==================================================================
+
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et  physique:
+c   -----------------------------------------------------
+
+c  Variables dynamiques
+         read(47,rec=irec) massem,pbarun,pbarvst,wn,tetan,phin
+        do l=1,llm
+           do j=1,jjm
+              do i=1,iip1
+                 pbarvn(i,j,l)=pbarvst(i,j,l)
+              enddo
+           enddo
+        enddo
+
+c  Variables physiques
+         read(49,rec=irec) ((xlecn(ig,l),ig=1,ngridmx),
+     s                                    l=1,9*llm+2+2*nbsrf)
+
+       do l=1,llm
+          do ig=1,ngridmx
+             coefkz(ig,l)=xlecn(ig,icoefkz+l-1)
+             frac_impa(ig,l)=xlecn(ig,ilei+l-1)
+             frac_nucl(ig,l)=xlecn(ig,ilec+l-1)
+          enddo
+       enddo
+       do l=1,nbsrf
+          do ig=1,ngridmx
+             ftsol(ig,l)=xlecn(ig,itsol+l-1)
+             pctsrf(ig,l)=xlecn(ig,ipsf+l-1)
+          enddo
+       enddo
+       do ig=1,ngridmx
+          yv1(ig)=xlecn(ig,izv1)
+          yu1(ig)=xlecn(ig,izu1)
+       enddo
+C
+      if(avant) then
+c   Simu directe
+       do l=1,llm
+          do ig=1,ngridmx
+             zmfu(ig,l)=xlecn(ig,imfu+l-1)
+             zmfd(ig,l)=xlecn(ig,imfd+l-1)
+             zde_u(ig,l)=xlecn(ig,ide_u+l-1)
+             zen_u(ig,l)=xlecn(ig,ien_u+l-1)
+             zde_d(ig,l)=xlecn(ig,ide_d+l-1)
+             zen_d(ig,l)=xlecn(ig,ien_d+l-1)
+          enddo
+       enddo
+      else
+c   Simu retro
+       do l=1,llm
+          do ig=1,ngridmx
+             zmfd(ig,l)=-xlecn(ig,imfu+l-1)
+             zmfu(ig,l)=-xlecn(ig,imfd+l-1)
+             zen_d(ig,l)=xlecn(ig,ide_u+l-1)
+             zde_d(ig,l)=xlecn(ig,ien_u+l-1)
+             zen_u(ig,l)=xlecn(ig,ide_d+l-1)
+             zde_u(ig,l)=xlecn(ig,ien_d+l-1)
+          enddo
+       enddo
+      endif
+
+c-----------------------------------------------------------------------
+c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
+c-----------------------------------------------------------------------
+
+      print*,'Ap redec irec'
+
+         call gr_dyn_fi(llm,iip1,jjp1,ngridmx,massem,massefi)
+
+         do ig=1,ngridmx
+            zcontrole(ig)=1.
+         enddo
+c   zmass=(max(massem(ig,l),massem(ig,l-1))/airefi(ig)
+         do l=2,llm
+            do ig=1,ngridmx
+               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
+               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
+               if(zflux.gt.0.9*zmass) then
+                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
+               endif
+            enddo
+         enddo
+
+         do ig=1,ngridmx
+            if(zcontrole(ig).lt.0.99999) then
+               print*,'ATTENTION !!! on reduit les flux de masse '
+               print*,'convectifs au point ig=',ig
+            endif
+         enddo
+
+         call gr_fi_dyn(1,ngridmx,iip1,jjp1,zcontrole,tmpdyn)
+
+         do l=1,llm
+            do ig=1,ngridmx
+               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
+               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
+               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
+               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
+               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
+               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
+            enddo
+         enddo
+
+
+      endif ! irec=0
+
+
+      RETURN
+      END
+
+
Index: LMDZ.3.3/branches/LF/libf/dyn3d/linear.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/linear.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/linear.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/linearb.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/linearb.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/linearb.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/logic.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/logic.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/logic.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/maketa
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/maketa	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/maketa	(revision 3)
@@ -0,0 +1,5 @@
+#@$-r  Maketa
+#@$-lt 00:4:00 -lT 00:4:00 
+cd $workdir/mod
+makegcm etat0_lmd
+#
Index: LMDZ.3.3/branches/LF/libf/dyn3d/massbar.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/massbar.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/massbar.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/massbarxy.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/massbarxy.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/massbarxy.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/massdair.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/massdair.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/massdair.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/merstrlF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/merstrlF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/merstrlF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/minmax.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/minmax.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/minmax.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/minmax2F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/minmax2F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/minmax2F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/moy2.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/moy2.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/moy2.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/multipl.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/multipl.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/multipl.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/multscal.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/multscal.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/multscal.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/nxgrad.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/nxgrad.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/nxgrad.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/nxgrad_gam.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/nxgrad_gam.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/nxgrad_gam.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/nxgradst.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/nxgradst.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/nxgradst.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/nxgraro2.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/nxgraro2.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/nxgraro2.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/nxgrarot.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/nxgrarot.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/nxgrarot.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/offline.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/offline.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/offline.F	(revision 3)
@@ -0,0 +1,640 @@
+      PROGRAM offline
+      USE ioipsl
+      IMPLICIT NONE
+
+c      ......   Version  du 17/04/96    ..........
+c=======================================================================
+c
+c   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+c   -------
+c   Modif special traceur F.Forget 05/94
+c
+c   Modifs M-A Filiberti 07/99
+C
+c   Objet:
+c   ------
+c
+c   GCM LMD nouvelle grille
+c
+c=======================================================================
+
+c   ...      modification de l'integration de q ( 26/04/94 )      ....
+
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+      integer ngridmx,nbsrf
+      PARAMETER (ngridmx=iim*(jjm-1)+2,nbsrf=4)
+c-----------------------------------------------------------------------
+
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d'1 jour
+      REAL dtdyn,dtav
+      INTEGER iday_step
+
+      INTEGER         longcles
+      PARAMETER     ( longcles = 20 )
+      REAL  clesphy0( longcles )
+      logical clefinit
+
+
+c   variables dynamiques
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
+      REAL pks(iip1,jjp1)                      ! exner (f pour filtre)
+      REAL phis(iip1,jjp1)                     ! geopotentiel au sol
+      REAL phi(iip1,jjp1,llm)                  ! geopotentiel
+      REAL w(iip1,jjp1,llm)                    ! vitesse verticale
+C
+C   variables physiques
+      real zmfd(ngridmx,llm),zde_d(ngridmx,llm),zen_d(ngridmx,llm)
+      REAL qfi(ngridmx,llm,nqmx)               ! champs advectes
+      real zmfu(ngridmx,llm),zde_u(ngridmx,llm),zen_u(ngridmx,llm)
+      real coefkz(ngridmx,llm)
+      real frac_impa(ngridmx,llm),frac_nucl(ngridmx,llm)
+      real pphis (ngridmx)
+      REAL airefi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx) ! latitude et long pour chaque point
+      real yu1(ngridmx), yv1(ngridmx)
+      real ftsol(ngridmx,nbsrf),pctsrf(ngridmx,nbsrf)
+
+C
+      character*10 file
+
+c variables dynamiques intermediaire pour le transport
+      REAL pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) !flux de masse
+
+      REAL masse(iip1,jjp1,llm)
+      REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm)
+      REAL teta(iip1,jjp1,llm)
+
+      INTEGER itau,irec,nrec,ldec,itauav
+      integer recmin,recmax,recstkmin,recstkmax
+      character*1 injecte,stoke
+      character*10 nom
+
+      integer jour0,isplit,nsplit_dyn,nsplit_phy,nsplit
+      logical debut,lectstart,rnpb
+
+      EXTERNAL inidissip,iniconst,inifilr
+      EXTERNAL inigeom
+      EXTERNAL exner_hyb,pression
+      EXTERNAL defrun_new
+
+      REAL time_0 ! temps de debut de simulation (% journee)
+
+      character*2 str2
+      INTEGER iq,j,i,l,nq,mode
+
+      real paprs(ngridmx,llm+1),pplay(ngridmx,llm),tempfi(ngridmx,llm)
+      real p(iip1,jjp1,llmp1),pk(iip1,jjp1,llm)
+
+      real lon_stat(nqmx),lat_stat(nqmx),zlon,zlat
+      integer i_stat(nqmx),j_stat(nqmx)
+      real intensite(nqmx)
+
+      integer iqmin,iqmax
+      integer npasinject
+      data npasinject/1/
+
+      integer histid, histvid, histaveid
+      real time_step, t_wrt, t_ops
+      integer itime_step
+      character*80 dynhist_file, dynhistave_file
+
+
+      logical avant
+
+      logical debutphy,redecoupage
+      DATA debutphy/.true./
+      
+      real unskap,pksurcp,smass(iip1,jjp1)
+      integer ig0,ii,jj,iii,ij
+
+     
+      REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)
+      REAL ps(iip1,jjp1),pkf(ip1jmp1,llm) 
+
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      descript = 'Run GCM LMDZ'
+
+c-----------------------------------------------------------------------
+
+
+      rad = 6400000
+      omeg = 7.272205e-05
+      g = 9.8
+      kappa = 0.285716
+      daysec = 86400
+      cpp = 1004.70885
+Cmaf a verifier....
+      preff = 101325.
+      pa= 50000.
+C
+
+      print*,'Nombre effectif de traceurs'
+      read(*,*) nq
+      write(*,*) nq
+      print*,'Splitting du pas de temps dynamique'
+      read(*,*) nsplit_dyn
+      write(*,*) nsplit_dyn
+      print*,'Splitting du pas de temps physique'
+      read(*,*) nsplit_phy
+      write(*,*) nsplit_phy
+      print*,'jour0, par rapport au debut du fichier fluxmass'
+      read(*,*) jour0
+      write(*,*) jour0
+      print*,'redecoupage (T) ou standard (F)'
+      read(*,'(l1)') redecoupage
+      write(*,*) redecoupage
+      print*,'Lecture fichier start (T)?'
+      read(*,'(l1)') lectstart
+      write(*,'(l1)') lectstart
+      print*,'Traceurs 1 et 2 = Rn222 et Pb'
+      read(*,'(l1)') rnpb
+      write(*,'(l1)') rnpb
+      print*,'Avant T ou arriere F?'
+      read(*,'(l1)') avant
+      write(*,'(l1)') avant
+      print*,'Index min et max des traceurs a initaliser'
+      read(*,*) iqmin,iqmax
+      write(*,*) iqmin,iqmax
+      print*,'localisation (lon, lat, intensite)'
+      if(iqmax.le.0) then
+         iqmin=iqmax+1
+      endif
+      do iq=iqmin,iqmax
+         read(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
+         write(*,*) lon_stat(iq),lat_stat(iq),intensite(iq)
+      enddo
+      print*,'Injection sur combien de pas de temps'
+      read(*,*) npasinject
+      write(*,*) npasinject
+      print*,'Records min et max pour le stokage et couche '
+     s    ,'verticale (specifique reseaux), def 0 0 1'
+      read(*,*) recstkmin,recstkmax,ldec
+      write(*,*) recstkmin,recstkmax,ldec
+
+c   redefinition du splitting
+      if(mod(nsplit_dyn,nsplit_phy).eq.0) then
+         nsplit=nsplit_phy
+      elseif (mod(nsplit_phy,nsplit_dyn).eq.0) then
+         nsplit=nsplit_dyn
+      else
+         stop'prendre un des deux nsplit doit diviser l autre'
+      endif
+      nsplit_dyn=nsplit_dyn/nsplit
+      nsplit_phy=nsplit_phy/nsplit
+      print*,'nsplit,nsplit_dyn,nsplit_phy'
+     s       ,nsplit,nsplit_dyn,nsplit_phy
+c   Lecture eventuelle 
+      time_0=0.
+
+      if(nq.gt.nqmx) stop'surdimensioner nqmx'
+
+      print*,'av initial0'
+      call initial0(nq*ijp1llm,q)
+
+      print*,'av lectstart'
+      if(lectstart) then
+         CALL dynetat0("start.nc",nq,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+         print*,'Lecture du start'
+      else
+         day_ini=0
+         anne_ini=0
+      endif
+      day_end=day_ini+nday
+
+
+      print*,'av defrun'
+c     open (99,file='run.def',status='old',form='formatted')
+      clefinit=.true.
+      CALL defrun_new( 99, clefinit, clesphy0 )
+c     close(99)
+
+      print*,'av iniconst'
+c   lecture du jour de demarrage
+c    premiere initialisation, eventuellement bidon
+      CALL iniconst
+      CALL inigeom
+
+C
+c  Lecture des entetes des fichiers de flux
+      if(redecoupage) then
+         call redecoupe(0,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl)
+      else
+         call lectflux(0,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phis)
+         call inigeom
+      endif
+
+c   controle sur les records
+      if(avant) then
+         recmin=2+(jour0-1)*iday_step
+         recmax=1+(jour0+nday-1)*iday_step
+      else
+         recmin=(jour0-nday)*iday_step+2
+         recmax=jour0*iday_step+1
+      endif
+      if(recmin.le.1.or.recmax.ge.nrec) then
+         print*,'Probleme de lecture '
+         print*,'recmin,recmax,nrec',recmin,recmax,nrec
+         stop
+      endif
+
+C on recalcule le nombre de pas de temps dans une journee
+c   istdyn est la frequence de stokage en "pas de temps dynamique" dans
+c   le modele on-line. dtvr est le pas de temps du meme modele en s.
+c iday-step est le nombre de lectures par jour (grand pas de temps). 
+      iday_step=daysec/(istdyn*dtvr)
+C
+      CALL iniconst
+c  on calcule le pas de temps 
+      dtvr    = daysec/FLOAT(iday_step)
+      dtphys=dtvr/(nsplit*nsplit_phy) ! a mettre apres iniconst!
+      print*,'Pas de temps physique ',dtphys
+
+
+C
+
+      call gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi)
+
+      print *,'Pas de temps dynamique', dtvr
+      print*,'Pas de temps physique ',dtphys
+
+c-----------------------------------------------------------------------
+C maf est ce utile ?
+
+      call suphec
+
+      CALL inifilr
+      print*,'Pas de temps physique ',dtphys
+      CALL inidissip( lstardis, nitergdiv, nitergrot, niterh   ,
+     *                tetagdiv, tetagrot , tetatemp              )
+      print*,'Pas de temps physique ',dtphys
+
+c-----------------------------------------------------------------------
+c   temps de depart et de fin:
+c   --------------------------
+
+      itau = 0
+      iday = dayref
+      time = time_0
+         IF(time.GT.1.) THEN
+          time = time-1.
+          iday = iday+1
+         ENDIF
+      print*,'Pas de temps physique ',dtphys
+
+c=======================================================================
+c   Initialisation des fichiers de sortie
+c=======================================================================
+
+      print*,'Initialisation de wrgras'
+      file='sol'
+      call inigrads(1,iip1
+     s  ,rlonv,180./pi,-190.,190.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+      file='atm'
+      print*,'Pas de temps physique ',dtphys
+      call inigrads(2,iip1
+     s  ,rlonv,180./pi,-190.,190.,jjp1,rlatu,-90.,90.,180./pi
+     s  ,llm,presnivs,1.
+     s  ,dtphys,file,'gcmq2 ')
+
+      print*,'dtphys ap inigrads ',dtphys
+
+      print*,'Ecriture du fichier de conditions aux limites'
+      open (98,file='limit',form='unformatted')
+      write(98) float(im),float(jm),float(nq),float(nday)
+      write(98) (rlonv(i)*180./pi,i=1,iip1)
+      write(98) (rlatu(j)*180./pi,j=1,jjp1)
+      write(98) ((phis(i,j)/g,i=1,iip1),j=1,jjp1)
+      close(98)
+
+      CALL dynredem0("restart.nc",day_end,anne_ini,phis,nq)
+
+c-----------------------------------------------------------------------
+c   Debut de la boucle en temps:
+c   ----------------------------
+
+      do itau=1,nday*iday_step
+
+          print*,'ITAU ITAU ITAU =',itau
+         injecte='.'
+         stoke='.'
+
+c Gestion du temps
+         if (avant) then
+            dtdyn=dtvr/float(nsplit*nsplit_dyn)
+            irec=1+(jour0-1)*iday_step+itau
+         else
+            dtdyn=-dtvr/float(nsplit*nsplit_dyn)
+            irec=1+jour0*iday_step-itau+1
+         endif
+
+         debut=itau.eq.1
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et physique:
+c   -----------------------------------------------------
+
+         print*,'CCCCC Appel a redecoupe au pas itau=',itau
+      if(redecoupage) then
+         call redecoupe(irec,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf, 
+     s     frac_impa,frac_nucl)
+      else
+         call lectflux(irec,masse,pbaru,pbarv,w,teta,phi,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf, 
+     s     frac_impa,frac_nucl,phis)
+      endif
+
+c    ...  ouverture du fichier de stockage netcdf ...
+C
+      IF (debut) then
+         dynhistave_file = 'dyn_hist_ave.nc'
+         day_ini=0
+         anne_ini=0
+         t_ops = periodav * daysec
+         t_wrt = periodav * daysec
+         dtav=dtvr/float(nsplit)
+         mode=1
+         CALL initdynav(dynhistave_file,day_ini,anne_ini,dtav,
+     .              t_ops, t_wrt, nq, histaveid)
+         pi=2.*asin(1.)
+         do iq=iqmin,iqmax
+            do l=1,llm
+               do j=1,jjp1
+                  do i=1,iip1
+                     q(i,j,l,iq)=0.
+                  enddo
+               enddo
+            enddo
+            zlon=lon_stat(iq)*pi/180.
+            zlat=lat_stat(iq)*pi/180.
+            CALL coordij(zlon,zlat,i_stat(iq),j_stat(iq))
+         enddo
+      ENDIF
+
+C calcul de la pression de surface.
+      do j=1,jjp1
+         do i=1,iip1
+            smass(i,j)=0.
+         enddo
+      enddo
+      do l=1,llm
+        do j=1,jjp1
+          do i=1,iip1
+             smass(i,j)=smass(i,j)+masse(i,j,l)
+          enddo
+       enddo
+      enddo
+      do j=1,jjp1
+         do i=1,iip1
+            ps (i,j)=smass(i,j)/aire(i,j)*g
+         end do
+      end do
+C
+C calcul de la pression et de pk (fonction d'Exner)
+C
+      CALL pression ( ip1jmp1, ap, bp, ps, p       )
+      CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf )
+c
+C
+      do jj=1,jjp1
+         do ii=1,iip1
+           phis(ii,jj)= phi(ii,jj,1)-teta(ii,jj,1)*
+     s                             (pks(ii,jj)-pk(ii,jj,1))
+         end do
+      end do
+
+c=======================================================================
+c   TERMES SOURCES OU PUITS
+c=======================================================================
+c   terme source reparti sur npasinject pas
+c   On injecte tous les traceurs de la meme facon
+      if (itau.le.npasinject) then
+        injecte='X'
+         do iq=iqmin,iqmax
+            print*,'INJECTION AU POINT ',lon_stat(iq),lat_stat(iq)
+     s      ,'     I,J=',i_stat(iq),j_stat(iq),jjp1-j_stat(iq)+1
+            q(i_stat(iq),j_stat(iq),1,iq)=
+     s      q(i_stat(iq),j_stat(iq),1,iq)
+     s      +intensite(iq)/masse(i_stat(iq),j_stat(iq),1)/npasinject
+         enddo
+         print*,'fin des injections'
+      endif
+c=======================================================================
+c   FIN DE LA PARTIE TERMES SOURCES
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Advection
+c   ----------
+
+c=======================================================================
+         do isplit=1,nsplit
+c=======================================================================
+CC MAF dans le cas du offline on ne fait pas la difference masse et massem
+            do iii=1,nsplit_dyn
+               do iq=1,nq
+                  CALL vlsplt(q(:,:,:,iq),2.,masse,w,pbaru,pbarv,dtdyn)
+               enddo
+
+c   mise à jour du champd de masse tenant compte de l'advection sur
+c   le pas de temps considere.
+
+            enddo
+
+            do iq=1,nq
+               write(str2,'(i2.2)') iq
+               if(mod(itau,1).eq.0) 
+     s         call diagadv(q(:,:,:,iq),masse,'Traceur '//str2)
+            enddo
+
+
+c-----------------------------------------------------------------------
+c   Physique  (lessivage dans phytrac maintenant) MAF
+c   ---------------------------------------------------------
+
+        if(physic) then
+         if(debut) then
+         latfi(1)=rlatu(1)*180./pi
+         lonfi(1)=0.
+         DO j=2,jjm
+            DO i=1,iim
+               latfi((j-2)*iim+1+i)= rlatu(j)*180./pi
+               lonfi((j-2)*iim+1+i)= rlonv(i)*180./pi
+            ENDDO
+         ENDDO
+         latfi(ngridmx)= rlatu(jjp1)*180./pi
+         lonfi(ngridmx)= 0.
+         endif
+
+c
+C Calcul de paprs et pplay et de temp
+c   -----------------------------------------------------------------
+c     .... paprs  definis aux (llm +1) interfaces des couches  ....
+c     .... pplay  definis aux (  llm )    milieux des couches  ....
+c   -----------------------------------------------------------------
+C
+      DO l = 1, llmp1
+        paprs( 1,l ) = p(1,1,l)
+        ig0 = 2
+          DO j = 2, jjm
+             DO i =1, iim
+              paprs( ig0,l ) = p(i,j,l)
+              ig0 = ig0 +1
+             ENDDO
+          ENDDO
+        paprs( ngridmx,l ) = p(1,jjp1,l)
+      ENDDO
+c
+      unskap   = 1./ kappa
+      DO l=1,llm
+
+         pksurcp     =  pk(1,1,l) / cpp
+         pplay(1,l)  =  preff * pksurcp ** unskap
+         tempfi(1,l)   =  teta(1,1,l) *  pksurcp
+         ig0         = 2
+
+         DO j = 2, jjm
+            DO i = 1, iim
+              pksurcp        = pk(i,j,l) / cpp
+              pplay(ig0,l)   = preff * pksurcp ** unskap
+              tempfi(ig0,l)    = teta(i,j,l)  * pksurcp
+              ig0            = ig0 + 1
+            ENDDO
+         ENDDO
+
+         pksurcp       = pk(1,jjp1,l) / cpp
+         pplay(ig0,l)  = preff * pksurcp ** unskap
+         tempfi (ig0,l)  = teta(1,jjp1,l)  * pksurcp
+      ENDDO
+c On passe le traceur et le geopot de surf  sur la grille physique
+             call gr_dyn_fi(llm*nq,iip1,jjp1,ngridmx,q,qfi)
+             call gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,pphis)
+
+             do iii=1,nsplit_phy
+C
+      print*,'dtphys avant phytrac ',dtphys
+             call phytrac(rnpb,
+     I                   ecritphy, debutphy,
+     I                   nq,
+     I                   ngridmx,llm,dtphys,
+     I                   tempfi,paprs,pplay,
+     I                   zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     I                   coefkz,yu1,yv1,ftsol,pctsrf,latfi,
+     I                   frac_impa, frac_nucl,
+     I                   lonfi,presnivs,airefi,pphis,
+     O                   qfi)
+C
+             debutphy= .FALSE.
+C
+             enddo ! nsplit_phy
+C
+c   On passe le traceur sur la grille dynamique.
+             call gr_fi_dyn(llm*nq,ngridmx,iip1,jjp1,qfi,q)
+
+             endif
+
+             itauav=(itau-1)*nsplit+isplit
+             CALL writedynav(histaveid, nq, itauav,vcov ,
+     ,                   ucov,teta,pk,phi,q,masse,ps,phis)
+
+         enddo ! isplit=1,nsplit
+
+         call histsync
+
+c-----------------------------------------------------------------------
+c    Calcul de ucov et vcov pour les sorties
+c   -------------------------------------
+
+         call massbar(masse, massebx, masseby )
+         do l=1,llm
+            do j=1,jjp1
+               do i=1,iip1
+               ucov(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j)*cu(i,j)
+     s         /istdyn
+               enddo
+            enddo
+            do j=1,jjm
+               do i=1,iip1
+               vcov(i,j,l)=pbarv(i,j,l)/masseby(i,j,l)*cv(i,j)*cv(i,j)
+     s         /istdyn
+               enddo
+            enddo
+         enddo
+
+         iday= dayref+itau/iday_step
+         time=
+     s   float(itau-(iday-dayref)*iday_step)/iday_step+time_0
+         IF(time.GT.1.) THEN
+            time = time-1.
+            iday = iday+1
+         ENDIF
+
+
+
+C
+c=======================================================================
+         if(irec.ge.recstkmin.and.irec.le.recstkmax) then
+            if (mod(itau,4).eq.0) then
+            stoke='X'
+               do iq=1,nq
+                  write(str2,'(i2.2)') iq
+                  nom='q'//str2
+                  call wrgrads(1,1,q(:,:,:,iq),nom,nom)
+                  call wrgrads(2,1,q(:,:,ldec,iq),nom,nom)
+               enddo
+            endif
+         endif
+
+         print*,'Record=',irec,'   stoke=',stoke,
+     s      '      injecte=',injecte
+
+      enddo ! itau
+
+      CALL dynredem1("restart.nc",0.0,
+     .          vcov,ucov,teta,q,nq,masse,ps)
+
+c=======================================================================
+C fermeture des fichiers netcdf
+          CALL histclo
+C
+ 300  FORMAT('1',/,15x,'run du pas',i7,2x,'au pas',i7,2x,
+     s 'c"est a dire dujour',i7,3x,'au jour',i7,/,/)
+
+      end
+C----------------------------------------------------------------------
Index: LMDZ.3.3/branches/LF/libf/dyn3d/para_netcdf.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/para_netcdf.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/para_netcdf.h	(revision 3)
@@ -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/branches/LF/libf/dyn3d/paramet.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/paramet.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/paramet.h	(revision 3)
@@ -0,0 +1,18 @@
+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, iip2= iim+2, iip3= iim+3, jjp1= jjm+1 )
+      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/branches/LF/libf/dyn3d/pbar.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/pbar.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/pbar.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/physdem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/physdem.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/physdem.F	(revision 3)
@@ -0,0 +1,398 @@
+      subroutine physdem(lonfi, latfi,phystep,radpas,co2_ppm,
+     .                   solaire, ts, ws, 
+     .                   sn, radsol, deltat, rugmer,
+     .                   agesno, zmea, zstd, zsig,
+     .                   zgam, zthe, zpic, zval,
+     .                   rugsrel)
+
+      IMPLICIT none
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 01/10/1999
+C Objet  : Ecriture des etats initiaux physiques
+c-------------------------------------------------------------
+c
+c
+c
+      INTEGER ivap
+      PARAMETER (ivap=1)
+c
+      REAL qsolmax
+      PARAMETER ( qsolmax = 150.0 )
+c
+#include "dimensions.h"
+#include "paramet.h"
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
+     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
+c-----------------------------------------------------------------------
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "comdissnew.h"
+#include "logic.h"
+#include "ener.h"
+#include "netcdf.inc"
+c
+      INTEGER nid
+
+c Ajout de quelques parametres orographiques (F. LOTT janvier 1995)
+
+      REAL zmea(iip1,jjp1),zstd(iip1,jjp1)
+      REAL zsig(iip1,jjp1),zgam(iip1,jjp1),zthe(iip1,jjp1)
+      REAL zpic(iip1,jjp1),zval(iip1,jjp1)
+      REAL rugsrel(iip1,jjp1)
+      INTEGER idayref,anneeref
+
+
+      integer ierr, idim1, idim2, nvarid
+
+c
+      REAL phystep
+      INTEGER radpas
+      REAL co2_ppm
+      REAL solaire
+      REAL latfi(klon), lonfi(klon)
+      REAL champhys(klon)
+      REAL ts(klon)
+      REAL deltat(klon)
+      REAL ws(klon)
+      REAL sn(klon)
+      REAL radsol(klon)
+      REAL rugmer(klon)
+      REAL agesno(klon)
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+
+c
+
+      EXTERNAL defrun_new,iniconst,geopot,inigeom,massdair,pression
+      EXTERNAL exner_hyb , SSUM
+c
+#include "serre.h"
+#include "clesph0.h"
+#include "fxyprim.h"
+c-----------------------------------------------------------------------
+c
+c  stockage sur le fichier Physique:
+c
+      ierr = NF_CREATE("startphy.nc", NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Pb d''ouverture du fichier startphy.nc'
+        WRITE(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28,
+     .                       "Fichier demmarage physique")
+c
+      ierr = NF_DEF_DIM (nid, "index", length, idim1)
+      ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2)
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1)  = phystep
+      tab_cntrl(2)  = radpas
+      tab_cntrl(3)  = co2_ppm
+      tab_cntrl(4)  = solaire
+      tab_cntrl(5)  = iflag_con
+      tab_cntrl(6)  = nbapp_rad
+c
+cc     Modif ( P. Le Van )
+c
+       tab_cntrl( 7 ) = 0. 
+       tab_cntrl( 8 ) = 0. 
+       tab_cntrl( 9 ) = 0. 
+       tab_cntrl(10 ) = 0. 
+       tab_cntrl(11 ) = 0. 
+       tab_cntrl(12 ) = 0. 
+
+      IF(  cycle_diurne )  tab_cntrl( 7 ) = 1. 
+      IF(   soil_model  )  tab_cntrl( 8 ) = 1. 
+      IF(    new_oliq   )  tab_cntrl( 9 ) = 1. 
+      IF(    ok_orodr   )  tab_cntrl(10 ) = 1. 
+      IF(    ok_orolf   )  tab_cntrl(11 ) = 1. 
+      IF(  ok_limitvrai )  tab_cntrl(12 ) = 1. 
+
+      tab_cntrl(13)  = dayref
+      tab_cntrl(14)  = anneeref
+
+
+cc   ***    new_oliq   (  commentaires de L. LI dans routine physique ) 
+cc   ***  ok_orodr  et ok_orolf   si on appelle l'orographie      ****
+
+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,lonfi)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,lonfi)
+#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,latfi)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,latfi)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "TS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "TS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25,
+     .                        "Temperature de la surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ts)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ts)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "QS", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "QS", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15,
+     .                        "Humidite du sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ws)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ws)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "SNOW", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "SNOW", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 5,
+     .                        "Neige")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sn)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,sn)
+#endif
+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, "DELTAT", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33,
+     .                        "Ecart de la SST (pour slab-ocean)")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Longueur de rugosite sur mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "AGESNO", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "AGESNO", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno)
+#endif
+c
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zmea, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+c
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zstd, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zsig, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zgam, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zthe, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zpic, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, zval, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+
+      CALL gr_dyn_fi(1, iip1, jjp1, klon, rugsrel, champhys)
+      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,champhys)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys)
+#endif
+c
+      ierr = NF_CLOSE(nid)
+
+      RETURN
+
+      END
Index: LMDZ.3.3/branches/LF/libf/dyn3d/pression.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/pression.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/pression.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/ps_amontF
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/ps_amontF	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/ps_amontF	(revision 3)
@@ -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/branches/LF/libf/dyn3d/psextbar.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/psextbar.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/psextbar.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/q_sat.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/q_sat.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/q_sat.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/qminimum.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/qminimum.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/qminimum.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/ran1.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/ran1.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/ran1.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/readhist.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/readhist.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/readhist.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/redecoupe.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/redecoupe.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/redecoupe.F	(revision 3)
@@ -0,0 +1,637 @@
+      SUBROUTINE redecoupe(irec,massemn,pbarun,pbarvn,wn,tetan,phin,
+     s     nrec,avant,airefi,
+     s     zmfu, zmfd, zen_u, zde_u,zen_d, zde_d, coefkz,
+     s     yu1,yv1,ftsol,pctsrf,
+     s     frac_impa,frac_nucl,phisn)
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+#include "tracstoke.h"
+
+      integer irec,nrec,i,j
+
+      integer ig,l
+      integer imo,jmo,imn,jmn,ii,jj,ig
+      parameter (imn=iim,jmn=jjm,imo=imn/2,jmo=(jmn+1)/2)
+      integer ngrido,ngridn
+      parameter(ngrido=(jmo-1)*imo+2,ngridn=(jmn-1)*imn+2)
+
+
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+
+      real zmfd(ngridn,llm),zde_d(ngridn,llm),zen_d(ngridn,llm)
+      real zmfu(ngridn,llm),zde_u(ngridn,llm),zen_u(ngridn,llm)
+      real coefkz(ngridn,llm)
+      real frac_impa(ngridn,llm),frac_nucl(ngridn,llm)
+      real yu1(ngridn), yv1(ngridn)
+      real ftsol(ngridn,nbsrf),pctsrf(ngridn,nbsrf)
+      integer imfu,imfd,ien_u,ide_u,
+     s      ien_d,ide_d,
+     s      icoefkz,izu1,izv1,
+     s      itsol,ipsf,
+     s      ilei, ilec
+      parameter(imfu=1,imfd=llm+1,ien_u=2*llm+1,ide_u=3*llm+1,
+     s      ien_d=4*llm+1,ide_d=5*llm+1,
+     s      icoefkz=6*llm+1,
+     s      ilei=7*llm+1,ilec=8*llm+1,
+     s      izu1=9*llm+1,izv1=9*llm+2,
+     s      itsol=9*llm+3,ipsf=9*llm+3+nbsrf)
+      logical avant
+
+
+      real massefi(ngridn,llm)
+
+      real massemn(imn+1,jmn+1,llm),tetan(imn+1,jmn+1,llm)
+      real pbarun(imn+1,jmn+1,llm),pbarvn(imn+1,jmn,llm)
+      real wn(imn+1,jmn+1,llm),phin(imn+1,jmn+1,llm)
+      real phisn(imn+1,jmn+1)
+
+      real massemo(imo+1,jmo+1,llm),tetao(imo+1,jmo+1,llm)
+      real pbaruo(imo+1,jmo+1,llm),pbarvo(imo+1,jmo,llm)
+      real wo(imo+1,jmo+1,llm),phio(imo+1,jmo+1,llm)
+      real phiso(imo+1,jmo+1)
+
+      real pbarvst(imo+1,jmo+1,llm)
+
+      real airefi(ngridn)
+
+      real xlecn(ngridn,9*llm+2+2*nbsrf),tmpn(imn+1,jmn+1)
+      real xleco(ngrido,9*llm+2+2*nbsrf),tmpo(imo+1,jmo+1)
+
+      real zcontrole(ngridn),zmass,tmpdyn(imn+1,jmn+1),zflux
+
+      real ziadvtrac,zrec,ziadvtrac2,zrec2
+      real zim,zjm,zlm,zklon,zklev
+
+      real zpi
+c  longitudes et latitudes lues
+      real rlonul(1:imo+1),rlatvl(1:jmo)
+      real rlonvl(1:imo+1),rlatul(1:jmo+1)
+c  longitudes et latitudes anciennes
+      real rlonuo(0:imo+1),rlatvo(0:jmo+1)
+c  longitudes et latitudes nouvelles
+      real rlonun(0:imn+1),rlatvn(0:jmn+1)
+      real aireo(imo+1,jmo+1)
+
+      integer ndecx(imo+1),ndecy(jmo+1)
+      real alphax(imn+1),alphay(jmn+1)
+      real alphaxo(imo+1)
+      real alpha(imn+1,jmn+1)
+
+      real aa,uu(0:imo+1),vv(imo+1,0:jmo+1)
+
+
+      integer iest(imo+1),iouest(imo+1)
+      integer jsud(jmo+1),jnord(jmo+1)
+
+      integer in,io,jn,jo,l,iin,jjn
+      integer i,j
+      real dlatm,dlatp,dlonm,dlonp
+
+
+      zpi=2.*asin(1.)
+
+
+c==================================================================
+c   Si le numero du record est 0 alors: INITIALISATION
+c==================================================================
+c
+      print*,'ENTREE DANS LECTFLUX'
+        print*,'IREC=',IREC
+      if(irec.eq.0) then
+
+        print*,'IREC==',0
+
+C test         call inigeom
+c==================================================================
+c   Definition des surdecoupages dans les deux directions
+c==================================================================
+
+      ndecx(1)=1
+      do io=2,imo
+         ndecx(io)=2
+      enddo
+      ndecx(imo+1)=1
+
+      ndecy(1)=1
+      do jo=2,jmo
+         ndecy(jo)=2
+      enddo
+      ndecy(jmo+1)=1
+
+      ii=0
+      do io=1,imo+1
+         ii=ii+ndecx(io)
+      enddo
+      if(ii.ne.iim) then
+         print*,'ii=',ii,'   iim=',iim
+         stop
+      endif
+
+      jj=0
+      do jo=1,jmo+1
+         jj=jj+ndecy(jo)
+      enddo
+      if(jj.ne.jjp1) then
+         print*,'jj=',jj,'   jjm=',jjm
+         stop
+      endif
+
+c==================================================================
+c   Calcul des jsud,... correspondant aux intersections des
+c   grilles.
+c==================================================================
+
+      iest(1)=0
+      do io=2,imo+1
+         iest(io)=iest(io-1)+ndecx(io-1)
+         iouest(io-1)=iest(io)
+      enddo
+      iouest(imo+1)=iest(imo+1)+ndecx(imo+1)
+
+      jnord(1)=0
+      do jo=2,jmo+1
+         jnord(jo)=jnord(jo-1)+ndecy(jo-1)
+         jsud(jo-1)=jnord(jo)
+      enddo
+      jsud(jmo+1)=jnord(jmo+1)+ndecy(jmo+1)
+
+c==================================================================
+c   ouverture des fichiers, lecture des entetes
+c==================================================================
+
+c   Fichier fluxmass
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:fluxmass")
+#endif
+      open(47,file='fluxmass',form='unformatted',
+     s     access='direct'
+     s     ,recl=4*6*(imo+1)*(jmo+1)*llm)
+      read(47,rec=1) zrec,dtvr,ziadvtrac,zim,zjm,zlm
+     s   ,rlonul,rlonvl,rlatul,rlatvl,aireo
+     s    ,phiso
+
+      print*,'zrec,dtvr,ziadvtrac,zim,zjm,zlm'
+      print*,zrec,dtvr,ziadvtrac,zim,zjm,zlm
+      if((imo-nint(zim))*(jmo-nint(zjm)).ne.0) then
+        print*,'Modifier les dimensions dans redecoupe '
+        print*,'Mettre imo=',zim,'   jmo=',zjm
+        stop
+      endif
+
+
+c  Fichier physique
+c  Fichier lessivage (supprime les donnees utiles sont dans "physique")
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:physique")
+#endif
+      open(49,file='physique',form='unformatted',
+     s     access='direct'
+     s     ,recl=4*ngrido*(9*llm+2+2*nbsrf))
+      read(49,rec=1) zrec2,ziadvtrac2,zklon,zklev
+      print*,'Entete du fichier physique'
+      print*,zrec2,ziadvtrac2,zklon,zklev
+
+      nrec=zrec
+      istdyn=ziadvtrac
+      istphy=ziadvtrac2
+
+c==================================================================
+c   Definition des anciennes latitudes et longitudes
+c   (qui pourraient etre relues plus tard)
+c==================================================================
+
+      rlonuo(0)=-zpi
+      do io=1,imo
+c        rlonuo(io)=2.*zpi/FLOAT(imo)*(io+0.5-0.5*FLOAT(imo)-1.)
+c        print*,'LON ',io,rlonuo(io),rlonul(io)
+         rlonuo(io)=rlonul(io)
+      enddo
+      rlonuo(imo+1)=zpi
+
+      rlatvo(0)=zpi/2.
+      do jo=1,jmo
+c        rlatvo(jo)=zpi/FLOAT(jmo)*(0.5*FLOAT(jmo)+1.-jo-0.5)
+c        print*,'LAT ',jo,rlatvo(jo),rlatvl(jo)
+         rlatvo(jo)=rlatvl(jo)
+      enddo
+      rlatvo(jmo+1)=-zpi/2.
+
+c     do jo=1,jmo+1
+c        do io=1,imo+1
+c           aireo(io,jo)=rad*rad
+c    s         *(rlonuo(io)-rlonuo(io-1))
+c    s         *(sin(rlatvo(jo-1))-sin(rlatvo(jo)))
+c           aireo(io,jo)=airel(io,jo)
+c        enddo
+c        aireo(1,jo)=aireo(1,jo)+aireo(imo+1,jo)
+c        aireo(imo+1,jo)=aireo(1,jo)
+c     enddo
+
+      do io=2,imo
+         alphaxo(io)=1.
+      enddo
+      alphaxo(1)=(rlonuo(1)-rlonuo(0))
+     s        /(rlonuo(1)-rlonuo(0)+rlonuo(imo+1)-rlonuo(imo))
+      alphaxo(imo+1)=1.-alphaxo(1)
+
+c==================================================================
+c    Definition des nouvelles latitudes et longitudes
+c==================================================================
+
+      rlonun(0)=-zpi
+      do io=1,imo+1
+         do iin=1,iouest(io)-iest(io)
+            in=iin+iest(io)
+            rlonun(in)=
+     s      rlonuo(io-1)+iin*(rlonuo(io)-rlonuo(io-1))
+     s      /ndecx(io)
+            alphax(in)=alphaxo(io)/ndecx(io)
+            print787,io,rlonuo(io-1)*180./zpi,in
+     s      ,iest(io),iouest(io),rlonun(in)*180./zpi,alphax(in)
+         enddo
+      enddo
+
+      rlatvn(0)=0.5*zpi
+      do jo=1,jmo+1
+         print*,'jo=',jo
+         do jjn=1,jsud(jo)-jnord(jo)
+            jn=jnord(jo)+jjn
+            rlatvn(jn)=rlatvo(jo-1)+jjn*(rlatvo(jo)-rlatvo(jo-1))
+     s      /ndecy(jo)
+            alphay(jn)=(sin(rlatvn(jn-1))-sin(rlatvn(jn)))
+     s                /(sin(rlatvo(jo-1))-sin(rlatvo(jo)))
+            print787,jo,rlatvo(jo-1)*180./zpi,jn
+     s      ,jnord(jo),jsud(jo),rlatvn(jn)*180./zpi,alphay(jn)
+         enddo
+      enddo
+
+787   format(i5,f10.2,3(i5),2(f10.2))
+      do in=1,imn
+         rlonu(in)=rlonun(in)
+         rlonv(in)=0.5*(rlonun(in)+rlonun(in-1))
+      enddo
+      rlonv(imn+1)=rlonv(1)+2.*zpi
+      rlonu(imn+1)=rlonu(1)+2.*zpi
+
+      do jn=1,jmn
+         rlatv(jn)=rlatvn(jn)
+      enddo
+      do jn=1,jmn+1
+         rlatu(jn)=0.5*(rlatvn(jn-1)+rlatvn(jn))
+      enddo
+
+      do jn=1,jmn+1
+         do in=1,imn
+            alpha(in,jn)=alphax(in)*alphay(jn)
+         enddo
+         alpha(imn+1,jn)=0.
+      enddo
+
+c     call dump2d(iip1,jjp1,alpha,'ALPHA   ')
+
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+
+
+      do j=1,jjp1
+         do i=1,iim
+            dlonp=rlonun(i)-rlonv(i)
+            dlonm=rlonv(i)-rlonun(i-1)
+            dlatp=sin(rlatvn(j-1))-sin(rlatu(j))
+            dlatm=sin(rlatu(j))-sin(rlatvn(j))
+            aireij1 ( i,j ) = rad*rad*dlatp*dlonp
+            aireij2 ( i,j ) = rad*rad*dlatm*dlonp
+            aireij3 ( i,j ) = rad*rad*dlatm*dlonm
+            aireij4 ( i,j ) = rad*rad*dlatp*dlonm
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+           enddo
+           aireij1(iip1,j)=aireij1(1,j)
+           aireij2(iip1,j)=aireij2(1,j)
+           aireij3(iip1,j)=aireij3(1,j)
+           aireij4(iip1,j)=aireij4(1,j)
+           aire(iip1,j)=aire(1,j)
+           alpha1(iip1,j)=alpha1(1,j)
+           alpha2(iip1,j)=alpha2(1,j)
+           alpha3(iip1,j)=alpha3(1,j)
+           alpha4(iip1,j)=alpha4(1,j)
+           alpha1p2(iip1,j)=alpha1p2(1,j)
+           alpha1p4(iip1,j)=alpha1p4(1,j)
+           alpha2p3(iip1,j)=alpha2p3(1,j)
+           alpha3p4(iip1,j)=alpha3p4(1,j)
+       enddo
+c     call dump2d(iip1,jjp1,aire,'AIRE   ')
+
+c     do jn=1,jjp1
+c        do in=1,iim
+c           aire(in,jn)=rad*rad*(sin(rlatvn(jn-1))-sin(rlatvn(jn)))
+c    s      *(rlonun(in)-rlonun(in-1))
+c           unsaire(in,jn)=1./aire(in,jn)
+c        enddo
+c        aire(iip1,jn)=aire(1,jn)
+c        unsaire(iip1,jn)=unsaire(1,jn)
+c     enddo
+c     call dump2d(iip1,jjp1,aire,'AIRE2   ')
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      unsaire(i,j) = 1./ aire(i,j)
+      aireu  (i,j) = aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                           aireij3(i+1,j)
+  41  CONTINUE
+      aireu  (iip1,j) = aireu  (1,j)
+      unsaire(iip1,j) = unsaire(1,j)
+  42  CONTINUE
+      DO 48 j = 1,jjm
+        DO i=1,iim
+         airev(i,j)     = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+       airev   (iip1,j) = airev(1,j)
+  48  CONTINUE
+      apoln=0.
+      apols=0.
+      do i=1,iim
+         apoln=apoln+aire(i,1)
+         apols=apols+aire(i,jjp1)
+      enddo
+
+
+
+      do jn=1,jjp1
+         do in=1,iim
+            cu(in,jn)=rad*cos(rlatu(jn))*(rlonv(in+1)-rlonv(in))
+         enddo
+         cu(iip1,jn)=cu(1,jn)
+      enddo
+      do jn=1,jjm
+         do in=1,iim+1
+            cv(in,jn)=rad*(rlatu(jn)-rlatu(jn+1))
+         enddo
+      enddo
+
+
+c==================================================================
+c   Fin des initialisations
+      else ! irec=0
+c==================================================================
+
+
+c-----------------------------------------------------------------------
+c   Lecture des fichiers fluxmass et  physique:
+c   -----------------------------------------------------
+
+c==================================================================
+c  Variables dynamiques
+c==================================================================
+
+         read(47,rec=irec) massemo,pbaruo,pbarvst,wo,tetao,phio
+        do l=1,llm
+           do j=1,jmo
+              do i=1,imo+1
+                 pbarvo(i,j,l)=pbarvst(i,j,l)
+              enddo
+           enddo
+        enddo
+
+         do l=1,llm
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        wn(in,jn,l)=alpha(in,jn)*wo(io,jo,l)
+                        massemn(in,jn,l)=alpha(in,jn)
+     s                     *massemo(io,jo,l)
+                        tetan(in,jn,l)=tetao(io,jo,l)
+                        phin(in,jn,l)=phio(io,jo,l)
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               wn(imn+1,jn,l)=wn(1,jn,l)
+               massemn(imn+1,jn,l)=massemn(1,jn,l)
+               tetan(imn+1,jn,l)=tetan(1,jn,l)
+               phin(imn+1,jn,l)=phin(1,jn,l)
+            enddo
+         enddo
+
+         do l=1,llm
+            do jo=1,jmo+1
+               uu(imo+1)=0.5*(pbaruo(imo,jo,l)+pbaruo(imo+1,jo,l))
+               uu(0)=uu(imo+1)
+               do io=1,imo
+                  uu(io)=pbaruo(io,jo,l)
+               enddo
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     aa=0.
+                     do in=iest(io)+1,iouest(io)
+                        aa=aa+alphax(in)
+                        pbarun(in,jn,l)=alphay(jn)*
+     s                    (uu(io-1)+aa*(uu(io)-uu(io-1)))
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn+1
+               pbarun(imn+1,jn,l)=pbarun(1,jn,l)
+            enddo
+         enddo
+
+         do l=1,llm
+            do jo=1,jmo
+               do io=1,imo+1
+                  vv(io,jo)=pbarvo(io,jo,l)
+               enddo
+            enddo
+            do io=1,imo+1
+               vv(io,0)=0.
+               vv(io,jmo+1)=0.
+            enddo
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  aa=0.
+c                 do jn=jnord(jo)+1,max(jsud(jo),jmo)
+                  do jn=jnord(jo)+1,min(jsud(jo),jmn)
+                     aa=aa+alphay(jn)
+                     do in=iest(io)+1,iouest(io)
+                        pbarvn(in,jn,l)=alphax(in)*
+     s                  (vv(io,jo-1)+aa*(vv(io,jo)-vv(io,jo-1)))
+                     enddo
+                  enddo
+               enddo
+            enddo
+            do jn=1,jmn
+               pbarvn(iip1,jn,l)=pbarvn(1,jn,l)
+            enddo
+         enddo
+
+c==================================================================
+c  Variables physiques
+c==================================================================
+         read(49,rec=irec) ((xleco(ig,l),ig=1,ngrido),
+     s                                    l=1,9*llm+2+2*nbsrf)
+
+c==================================================================
+c  Passage  a la nouvelle grille
+c==================================================================
+         do l=1,9*llm+2+2*nbsrf
+c   passage aa la grille dynamique ancienne
+            do io=1,imo+1
+               tmpo(io,1)=xleco(1,l)
+               tmpo(io,jmo+1)=xleco(ngrido,l)
+            enddo
+            do jo=2,jmo
+               do io=1,imo
+                  tmpo(io,jo)=xleco((jo-2)*imo+io+1,l)
+               enddo
+               tmpo(imo+1,jo)=tmpo(1,jo)
+            enddo
+c   passage a la grillle dynamique nouvelle
+            do jo=1,jmo+1
+               do io=1,imo+1
+                  do jn=jnord(jo)+1,jsud(jo)
+                     do in=iest(io)+1,iouest(io)
+                        tmpn(in,jn)=tmpo(io,jo)
+                     enddo
+                  enddo
+               enddo
+            enddo
+c   passage a la grille physique nouvelle
+            xlecn(1,l)=tmpn(1,1)
+            xlecn(ngridn,l)=tmpn(1,jmn+1)
+            do jn=2,jmn
+               do in=1,imn
+                  xlecn((jn-2)*imn+in+1,l)=tmpn(in,jn)
+               enddo
+            enddo
+         enddo
+
+c==================================================================
+
+       do l=1,llm
+          do ig=1,ngridn
+             coefkz(ig,l)=xlecn(ig,icoefkz+l-1)
+             frac_impa(ig,l)=xlecn(ig,ilei+l-1)
+             frac_nucl(ig,l)=xlecn(ig,ilec+l-1)
+          enddo
+       enddo
+       do l=1,nbsrf
+          do ig=1,ngridn
+             ftsol(ig,l)=xlecn(ig,itsol+l-1)
+             pctsrf(ig,l)=xlecn(ig,ipsf+l-1)
+          enddo
+       enddo
+       do ig=1,ngridn
+          yv1(ig)=xlecn(ig,izv1)
+          yu1(ig)=xlecn(ig,izu1)
+       enddo
+C
+      if(avant) then
+c   Simu directe
+       do l=1,llm
+          do ig=1,ngridn
+             zmfu(ig,l)=xlecn(ig,imfu+l-1)
+             zmfd(ig,l)=xlecn(ig,imfd+l-1)
+             zde_u(ig,l)=xlecn(ig,ide_u+l-1)
+             zen_u(ig,l)=xlecn(ig,ien_u+l-1)
+             zde_d(ig,l)=xlecn(ig,ide_d+l-1)
+             zen_d(ig,l)=xlecn(ig,ien_d+l-1)
+          enddo
+       enddo
+      else
+c   Simu retro
+       do l=1,llm
+          do ig=1,ngridn
+             zmfd(ig,l)=-xlecn(ig,imfu+l-1)
+             zmfu(ig,l)=-xlecn(ig,imfd+l-1)
+             zen_d(ig,l)=xlecn(ig,ide_u+l-1)
+             zde_d(ig,l)=xlecn(ig,ien_u+l-1)
+             zen_u(ig,l)=xlecn(ig,ide_d+l-1)
+             zde_u(ig,l)=xlecn(ig,ien_d+l-1)
+          enddo
+       enddo
+      endif
+
+c-----------------------------------------------------------------------
+c   PETIT CONTROLE SUR LES FLUX CONVECTIFS...
+c-----------------------------------------------------------------------
+
+         call gr_dyn_fi(llm,iip1,jjp1,ngridn,massemn,massefi)
+
+      print*,'Ap redec irec'
+         do ig=1,ngridn
+            zcontrole(ig)=1.
+         enddo
+c   zmass=(max(massemn(ig,l),massemn(ig,l-1))/airefi(ig)
+         do l=2,llm
+            do ig=1,ngridn
+               zmass=max(massefi(ig,l),massefi(ig,l-1))/airefi(ig)
+               zflux=max(abs(zmfu(ig,l)),abs(zmfd(ig,l)))*dtphys
+               if(zflux.gt.0.9*zmass) then
+                 zcontrole(ig)=min(zcontrole(ig),0.9*zmass/zflux)
+               endif
+            enddo
+         enddo
+
+         do ig=1,ngridn
+            if(zcontrole(ig).lt.0.99999) then
+               print*,'ATTENTION !!! on reduit les flux de masse '
+               print*,'convectifs au point ig=',ig
+            endif
+         enddo
+
+         call gr_fi_dyn(1,ngridn,iip1,jjp1,zcontrole,tmpdyn)
+
+         do l=1,llm
+            do ig=1,ngridn
+               zmfu(ig,l)=zmfu(ig,l)*zcontrole(ig)
+               zmfd(ig,l)=zmfd(ig,l)*zcontrole(ig)
+               zen_u(ig,l)=zen_u(ig,l)*zcontrole(ig)
+               zde_u(ig,l)=zde_u(ig,l)*zcontrole(ig)
+               zen_d(ig,l)=zen_d(ig,l)*zcontrole(ig)
+               zde_d(ig,l)=zde_d(ig,l)*zcontrole(ig)
+            enddo
+         enddo
+
+
+      endif ! irec=0
+
+
+      RETURN
+      END
+
+
Index: LMDZ.3.3/branches/LF/libf/dyn3d/reduce_i.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/reduce_i.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/reduce_i.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/rotat.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/rotat.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/rotat.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/rotat_nfil.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/rotat_nfil.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/rotat_nfil.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/rotatf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/rotatf.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/rotatf.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/rotatst.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/rotatst.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/rotatst.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/run.def
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/run.def	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/run.def	(revision 3)
@@ -0,0 +1,187 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Jour de l'etat initial ( = 350  si 20 Decembre ,par expl. ,comme ici ) 
+   dayref
+ 350
+
+-  Annee de l'etat  initial (   avec  4  chiffres   )                        
+   anneeref
+ 1987
+
+- Nombre de jours d'integration                                         
+     nday
+ 2
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 1440
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 5
+
+- periode d'ecriture du fichier histoire (en jour)                      
+    iecri
+ 100
+
+- periode de stockage fichier histmoy (en jour)                         
+ periodav
+ 60.
+
+- periode de la dissipation (en pas)                                    
+  idissip
+ 10
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- nombre d'iterations de l'operateur de dissipation   gradiv            
+nitergdiv
+ 1
+
+- nombre d'iterations de l'operateur de dissipation  nxgradrot          
+nitergrot
+ 2
+
+- nombre d'iterations de l'operateur de dissipation  divgrad            
+   niterh
+ 2
+
+- temps de dissipation des plus petites long.d ondes pour u,v (gradiv)  
+ tetagdiv
+ 3000.
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+ tetagrot
+ 3000.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 3000.
+
+- coefficient pour gamdissip                                            
+  coefdis
+ 0.
+
+- choix du shema d'integration temporelle (Matsuno ou Matsuno-leapfrog) 
+  purmats
+ F
+
+- avec ou sans physique                                                 
+   physic
+ T
+
+- periode de la physique (en pas)                                       
+  iphysiq
+ 15
+
+- frequence (en  jours ) de l'ecriture du fichier histphy               
+ ecritphy
+ 4
+
+-  Cycle diurne  ou non                 
+ cycle_diurne
+ T
+
+-  Soil Model  ou non               
+ soil_model
+ F
+
+-  Choix ou non  de  New oliq               
+ new_oliq
+ T
+
+-  Orodr  ou  non   pour l orographie              
+  ok_orodr
+ T
+
+-  Orolf  ou  non   pour l orographie              
+  ok_orolf
+ T
+
+-   Si = .T. ,  lecture du fichier limit avec la bonne annee             
+  ok_limitvrai
+ T
+
+- Nombre  d'appels des routines de rayonnements ( par jour)                 
+  nbapp_rad
+ 12
+
+-  Flag  pour la convection ( 1 pour LMD,  2 pour Tiedtke, 3  CCM )             
+  iflag_con
+ 2
+
+- longitude en degres du centre du zoom                                 
+   clon
+ 63.
+
+- latitude en degres du centre du zoom                                  
+   clat
+ 0.
+
+- facteur de grossissement du zoom,selon longitude                      
+  grossismx
+ 2.5
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 2.5
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ T
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.291667
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.291667
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .true. , sinon y = latit.         
+  ysinus
+ T
+
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+cc
+c   Autres  parametres ou cles  , non places dans run.def  mais
+c             dans les routines .
+cc
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+cc
+cc  A )   iadv(iq )  , iq =1, nqmx , avec  iadv = 1  , shema humid.
+cc                                                  specifique LMD
+cc
+cc                                avec  iadv = 2  , shema amont
+cc
+cc                (  avec a l'interieur de amont , la cle amont_qs ) 
+cc
+cc                                avec  iadv = 3 , shema Van_Leer
+cc
+cc                                           dans  ***  gcm.F  ****
+cc 
+cc  B )  ok_oasis   , pour coupleur Oasis  , dans  *** physiq.F ***
+cc
+cc  C )  ok_ocean                            dans  *** physiq.F ***
+cc
+cc  D )  ok_journe , ok_instan, ok_region   pour sorties analyses
+c
+cc                                           dans  *** physiq.F ***
+cc
+cc  E ) nvm  : nbre  de vegetations    
+cc                                           dans  *** physiq.F ***
+
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: LMDZ.3.3/branches/LF/libf/dyn3d/serre.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/serre.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/serre.h	(revision 3)
@@ -0,0 +1,6 @@
+c..include serre.h
+c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
+     ,  grossismx, grossismy, dzoomx, dzoomy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
+     ,  grossismx, grossismy, dzoomx, dzoomy
Index: LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/sortvarc0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/sortvarc0.F	(revision 3)
@@ -0,0 +1,139 @@
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time )
+      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 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/branches/LF/libf/dyn3d/spline.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/spline.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/spline.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/splint.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/splint.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/splint.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/startvar.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/startvar.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/startvar.F	(revision 3)
@@ -0,0 +1,974 @@
+      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)
+    !            
+    !
+    !        - A 1D variable on the physical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp)
+    !
+    !
+    !         - A 3D variable on the dynamical grid :
+    !            CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp)
+    !
+    !
+    !         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 (:)  :: lev_dyn
+      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)
+    !
+    !    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
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(inout) :: champ(iml,jml)
+      REAL, INTENT(in) :: val_exp
+    !
+    !   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
+                      !
+                      CALL start_init_orog( iml, jml, lon_in, lat_in)
+                      !
+                  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)
+                      !
+                  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)
+                      !
+                  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)
+                      !
+                  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)
+                      !
+                  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)
+    !
+      INTEGER, INTENT(in) :: iml, jml
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1), fid
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+      INTEGER :: iret
+      REAL, ALLOCATABLE :: relief_hi(:,:)
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      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))
+      IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_rad(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_rad(:) = lon_rel(:,1) 
+      ENDIF
+      ALLOCATE(lat_rad(jml_rel))
+      IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_rad(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_rad(:) = lat_rel(1,:) 
+      ENDIF
+    !
+    !
+      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))
+    !
+      CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi,
+     . iml-1, jml, lon_in, lat_in, 
+     . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, tmp_int)
+    !
+      masque(:,:) = FLOAT(tmp_int(:,:))
+    !
+    !  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
+    !
+    !   Build land-sea mask
+    !
+    !
+      RETURN
+    !
+      END SUBROUTINE start_init_orog
+    !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !
+      SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, 
+     .lat_in, nbindex, champ, val_exp)
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, nbindex
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      REAL, INTENT(inout) :: champ(nbindex)
+      REAL, INTENT(in) :: val_exp
+    !
+    !
+    !   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)
+              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)
+              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)
+              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)
+              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)
+              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)
+              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)
+              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)
+              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)
+              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)
+              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)
+    !
+      INTEGER, INTENT(in) :: iml, jml
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+    !
+    !  LOCAL
+    !
+      REAL :: lev(1), date, dt
+      INTEGER :: itau(1)
+      INTEGER ::  llm_tmp, ttm_tmp
+      INTEGER :: i, j
+    !
+      CHARACTER*120 :: physfname
+      LOGICAL :: check=.TRUE.
+    !
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      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))
+      IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_rad(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_rad(:) = lon_phys(:,1) 
+      ENDIF
+      ALLOCATE(lat_rad(jml_phys))
+      IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_rad(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_rad(:) = 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)
+      CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     . var_ana, iml-1, jml, lon_in, lat_in, tmp_var)
+      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)
+      CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad,
+     . var_ana, iml-1, jml, lon_in, lat_in, tmp_var)
+      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)
+    !
+    !   ARGUMENTS
+    !
+      CHARACTER*(*), INTENT(in) :: varname
+      INTEGER, INTENT(in) :: iml, jml, lml
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+      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
+    !
+    !    LOCAL
+    !
+      INTEGER :: il, ij, ii
+      REAL :: xppn, xpps
+    !
+    !   C'est vraiment une galere de devoir rajouter tant de commons just pour avoir les aires.
+    !   Il faudrait mettre une structure plus flexible et moins dangereuse.
+    !
+#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)
+            ENDIF
+            CALL start_inter_3d('U', iml, jml, lml, lon_in,
+     .                           lat_in, pls, champ)
+            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)
+            ENDIF
+            CALL start_inter_3d('V', iml, jml, lml, lon_in,
+     .                          lat_in, pls, champ)
+            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)
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .                           lat_in, pls, champ)
+ 
+          CASE ('tpot')
+            IF ( .NOT.ALLOCATED(psol_dyn)) THEN
+              CALL start_init_dyn( iml, jml, lon_in, lat_in)
+            ENDIF
+            CALL start_inter_3d('TEMP', iml, jml, lml, lon_in,
+     .                           lat_in, pls, champ)
+            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))/apoln
+                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)
+            ENDIF
+            CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in,
+     .                           pls, champ)
+            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))/apoln
+                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)
+    !
+      INTEGER, INTENT(in) :: iml, jml
+      REAL, INTENT(in) :: lon_in(iml), lat_in(jml)
+    !
+    !  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 :: var_ana(:,:), tmp_var(:,:), z(:,:)
+      REAL, ALLOCATABLE :: xppn(:), xpps(:)
+      LOGICAL :: allo
+    !
+    !   Ce n'est pas tres pratique d'avoir a charger 3 include pour avoir la grille du modele
+    !
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom2.h"
+    !
+      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 (lev_dyn(llm_dyn), stat=iret)
+    !
+      CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn,
+     . lon_dyn, lat_dyn, lev_dyn, 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)
+       
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_rad(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_rad(:) = lon_dyn(:,1) 
+      ENDIF
+      ALLOCATE(lat_rad(jml_dyn))
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_rad(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_rad(:) = 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)
+      CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      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)
+      CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana,
+     .               iml-1, jml, lon_in, lat_in, tmp_var)
+      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)
+      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)
+            !
+      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, pls_in, var3d)
+    !
+    !    This subroutine gets a variables from a 3D file and does the interpolations needed
+    !
+    !
+    !    ARGUMENTS
+    !
+      CHARACTER*(*) :: varname
+      INTEGER :: iml, jml, lml
+      REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml)
+      REAL :: var3d(iml, jml, lml)
+    !
+    !  LOCAL
+    !
+      INTEGER :: ii, ij, il
+      REAL :: bx, by
+      REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:)
+      REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:)
+      REAL, ALLOCATABLE :: ax(:), ay(:), yder(:)
+      INTEGER, ALLOCATABLE :: lind(:)
+    !
+      LOGICAL :: check = .TRUE.
+    !
+      IF ( .NOT. ALLOCATED(var_ana3d)) THEN
+          ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn))
+      ENDIF
+    !
+    !
+      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))
+      IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lon_rad(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lon_rad(:) = lon_dyn(:,1) 
+      ENDIF
+      ALLOCATE(lat_rad(jml_dyn))
+      IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN
+          lat_rad(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0
+      ELSE
+          lat_rad(:) = lat_dyn(1,:) 
+      ENDIF
+    !
+      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
+        !
+        CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, 
+     .var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d)
+        !
+        CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml)
+        !
+       ENDDO
+       !
+       !  IF needed we return the vertical axis. The spline interpolation
+       !  Requires the coordinate to be in increasing order.
+    !
+      IF ( lev_dyn(1) .LT. lev_dyn(llm_dyn)) THEN
+          DO il=1,llm_dyn
+            lind(il) = il
+          ENDDO        
+      ELSE
+          DO il=1,llm_dyn
+            lind(il) = llm_dyn-il+1
+          ENDDO
+      ENDIF
+    !
+      DO ij=1,jml
+        DO ii=1,iml-1
+          !
+          ax(:) = lev_dyn(lind(:)) * 100
+          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
+
+      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/branches/LF/libf/dyn3d/substr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/substr.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/substr.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/temps.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/temps.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/temps.h	(revision 3)
@@ -0,0 +1,11 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'temps.h'
+
+      COMMON/temps/itaufin,dt,
+     s  day_ini,day_end,anne_ini
+
+      INTEGER  itaufin
+      INTEGER*4 day_ini,day_end,anne_ini
+      REAL     dt
+
+c-----------------------------------------------------------------------
Index: LMDZ.3.3/branches/LF/libf/dyn3d/test_period.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/test_period.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/test_period.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/testharm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/testharm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/testharm.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/tourpot.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/tourpot.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/tourpot.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/traceur.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/traceur.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/traceur.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/tracstoke.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/tracstoke.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/tracstoke.h	(revision 3)
@@ -0,0 +1,2 @@
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: LMDZ.3.3/branches/LF/libf/dyn3d/tracvl.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/tracvl.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/tracvl.F	(revision 3)
@@ -0,0 +1,112 @@
+      SUBROUTINE tracvl(numvanle,iapp_tracvl,nq,pbaru,pbarv ,
+     *                            p,  masse , q, iapptrac    )
+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"
+
+      INTEGER nq,iapp_tracvl
+
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1 )
+
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
+
+      INTEGER iapptrac
+
+      INTEGER iadvtr, numvanle
+      INTEGER ij,l,iq
+      REAL zdpmin, zdpmax
+      EXTERNAL  minmax
+ 
+      SAVE iadvtr, massem,pbaruc,pbarvc
+      DATA iadvtr/0/
+
+      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.
+         DO iq = numvanle, 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/branches/LF/libf/dyn3d/vanleer.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/vanleer.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/vanleer.F	(revision 3)
@@ -0,0 +1,118 @@
+      SUBROUTINE vanleer(numvanle,iapp_tracvl,nq,q,pbaru,pbarv ,
+     *                                    p ,masse,  dq          )
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget 
+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 
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nq),dq( ip1jmp1,llm,nq )
+
+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  ..................................................................
+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                       )
+
+      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/branches/LF/libf/dyn3d/vitvert.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/vitvert.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/vitvert.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/vlsplt.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/vlsplt.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/vlsplt.F	(revision 3)
@@ -0,0 +1,885 @@
+      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
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l
+c
+      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      PRINT*,'Debut vlsplt version debug sans vly'
+
+        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 vlx     ')
+      call vlx(zq,pente_max,zm,mu)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vly     ')
+
+      call vly(zq,pente_max,zm,mv)
+
+
+c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
+
+      call vlz(zq,pente_max,zm,mw)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vly     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vly     ')
+
+      call vly(zq,pente_max,zm,mv)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlx     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vlx     ')
+
+      call vlx(zq,pente_max,zm,mu)
+
+c     call minmaxq(zq,qmin,qmax,'apres vlx     ')
+c     call minmaxq(zm,qmin,qmax,'M apres vlx     ')
+
+
+      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
+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 )
+      REAL q(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 temps1,temps2,temps3,temps4,temps5
+      SAVE 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
+
+      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.
+      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)*(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   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  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 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)
+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)=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
+         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
+      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
+      SUBROUTINE minmaxq(zq,qmin,qmax,comment)
+
+#include "dimensions.h"
+#include "paramet.h"
+
+      CHARACTER*(*) comment
+      real qmin,qmax
+      real zq(ip1jmp1,llm)
+
+      INTEGER jadrs(ip1jmp1), jbad, k, i
+
+      DO k = 1, llm
+         jbad = 0
+         DO i = 1, ip1jmp1
+         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
+cc            PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k)
+         ENDDO
+         ENDIF
+      ENDDO
+
+      return
+      end
+
+
+
Index: LMDZ.3.3/branches/LF/libf/dyn3d/wrgrads.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/wrgrads.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/wrgrads.F	(revision 3)
@@ -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/branches/LF/libf/dyn3d/writeav.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/dyn3d/writeav.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/dyn3d/writeav.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/acc.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/acc.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/acc.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/coefils.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/coefils.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/coefils.h	(revision 3)
@@ -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/branches/LF/libf/filtrez/eigen.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/eigen.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/eigen.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/eigen_sort.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/eigen_sort.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/eigen_sort.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/filtreg.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/filtreg.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/filtreg.F	(revision 3)
@@ -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 fil
+     *-trer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fil
+     *-trer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/filtrez/inifgn.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/inifgn.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/inifgn.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/inifilr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/inifilr.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/inifilr.F	(revision 3)
@@ -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/branches/LF/libf/filtrez/jacobi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/jacobi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/jacobi.F	(revision 3)
@@ -0,0 +1,94 @@
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      PARAMETER (NMAX=200)
+      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/branches/LF/libf/filtrez/parafilt.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/filtrez/parafilt.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/filtrez/parafilt.h	(revision 3)
@@ -0,0 +1,34 @@
+        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)
+         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 96 72 19 non-zoom:
+ccc      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/branches/LF/libf/grid/dimension/dimensions.48.32.19.t4
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.48.32.19.t4	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.48.32.19.t4	(revision 3)
@@ -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/branches/LF/libf/grid/dimension/dimensions.48.32.19.t6
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.48.32.19.t6	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.48.32.19.t6	(revision 3)
@@ -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/branches/LF/libf/grid/dimension/dimensions.96.72.19.t4
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.96.72.19.t4	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/dimension/dimensions.96.72.19.t4	(revision 3)
@@ -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/branches/LF/libf/grid/dimension/makdim
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/dimension/makdim	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/dimension/makdim	(revision 3)
@@ -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/branches/LF/libf/grid/fxy_new.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/fxy_new.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/fxy_new.h	(revision 3)
@@ -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/branches/LF/libf/grid/fxy_reg.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/fxy_reg.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/fxy_reg.h	(revision 3)
@@ -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/branches/LF/libf/grid/fxy_sin.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/fxy_sin.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/fxy_sin.h	(revision 3)
@@ -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/branches/LF/libf/grid/fxyprim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/grid/fxyprim.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/grid/fxyprim.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/FCTTRE.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/FCTTRE.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/FCTTRE.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/LISEZMOI
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/LISEZMOI	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/LISEZMOI	(revision 3)
@@ -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/branches/LF/libf/phylmd/YOECUMF.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOECUMF.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/YOECUMF.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/YOEGWD.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOEGWD.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/YOEGWD.h	(revision 3)
@@ -0,0 +1,9 @@
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+C     -----------------------------------------------------------------
+C
+      COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+     *        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
+C
+
+
Index: LMDZ.3.3/branches/LF/libf/phylmd/YOETHF.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOETHF.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/YOETHF.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/YOMCST.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/YOMCST.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/YOMCST.h	(revision 3)
@@ -0,0 +1,33 @@
+C A1.0 Fundamental constants
+      REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
+C A1.1 Astronomical constants
+      REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+c A1.1.bis Constantes concernant l'orbite de la Terre:
+      REAL R_ecc, R_peri, R_incl
+C A1.2 Geoide
+      REAL RA,RG,R1SA
+C A1.3 Radiation
+      REAL RSIGMA,RI0
+C A1.4 Thermodynamic gas phase
+      REAL R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL RKAPPA,RETV
+C A1.5,6 Thermodynamic liquid,solid phases
+      REAL RCW,RCS
+C A1.7 Thermodynamic transition of phase
+      REAL RLVTT,RLSTT,RLMLT,RTT,RATM
+C A1.8 Curve of saturation
+      REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL RALPD,RBETD,RGAMD
+C
+      COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO
+     S      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA
+     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
+C    ------------------------------------------------------------------
Index: LMDZ.3.3/branches/LF/libf/phylmd/ajsec.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/ajsec.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/ajsec.F	(revision 3)
@@ -0,0 +1,309 @@
+      SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q, itr, tr, d_tr)
+      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 it, itr
+      REAL tr(klon,klev,nbtr), d_tr(klon,klev,nbtr)
+      REAL ztr(klon,klev,nbtr), trm(nbtr)
+c
+      INTEGER limbas, limhau ! les couches a ajuster
+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
+      IF (itr.GE.1) THEN
+      DO it = 1, itr
+      DO k = 1, klev
+      DO i = 1, klon
+         d_tr(i,k,it) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      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
+      IF (itr.GE.1) THEN
+      DO it = 1, itr
+      DO k = limbas, limhau
+      DO i = 1, klon
+         ztr(i,k,it) = tr(i,k,it)
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      DO k = limbas, limhau
+      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)
+              IF (itr.GE.1) THEN
+              DO it = 1, itr
+                trm(it) = ztr(i,k2,it)
+              ENDDO
+              ENDIF
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                IF (itr.GE.1) THEN
+                DO it = 1, itr
+                trm(it) = trm(it) +
+     .                    zpkdp(i,k) * (ztr(i,k,it)-trm(it)) / sm
+                ENDDO
+                ENDIF
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  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
+              IF (itr.GE.1) THEN
+              DO it = 1, itr
+              DO k = k1, k2
+                ztr(i,k,it) = trm(it)
+              ENDDO
+              ENDDO
+              ENDIF
+              k2 = k2 + 1
+            ENDIF
+          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 (itr.GE.1) THEN
+      DO it = 1, itr
+c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_tr(i,k,it) = ztr(i,k,it) - tr(i,k,it)
+      ENDDO
+      ENDDO
+c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_tr(i,k,it) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_tr(i,k,it) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+c
+      ENDDO
+      ENDIF
+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/branches/LF/libf/phylmd/albedo.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/albedo.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/albedo.F	(revision 3)
@@ -0,0 +1,126 @@
+      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
+      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
+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
+      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 fauxo
+      INTEGER i
+c
+      DO i = 1, klon
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = 1.1*( .03 + .630/( 1. + fauxo*fauxo))
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+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/branches/LF/libf/phylmd/clesphys.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/clesphys.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/clesphys.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/clim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/clim.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/clim.h	(revision 3)
@@ -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 = 16 )
+      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/branches/LF/libf/phylmd/clmain.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/clmain.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/clmain.F	(revision 3)
@@ -0,0 +1,1615 @@
+      SUBROUTINE clmain(dtime,pctsrf,t,q,u,v,
+     .                  soil_model,ts,soilcap,soilflux,
+     .                  paprs,pplay,radsol,snow,qsol,
+     .                  xlat, rugos,
+     .                  d_t,d_q,d_u,d_v,d_ts,
+     .                  flux_t,flux_q,flux_u,flux_v,cdragh,cdragm,
+     .                  rugmer, dflux_t,dflux_q,
+     .                  zcoefh,zu1,zv1)
+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).
+ 
+      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 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 capsol---input-R- inversion de l'effective capacite du sol (J/m2/K)
+c beta-----input-R- coefficient de l'evaporation reelle (0 a 1)
+c dif_grnd-input-R- coeff. de diffusion (chaleur) vers le sol profond
+c xlat-----input-R- latitude en degree
+c rugos----input-R- longeur de rugosite (en 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 rugmer---output-R- longeur de rugosite sur mer (m)
+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
+      LOGICAL soil_model
+c
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev), radsol(klon)
+      REAL xlat(klon)
+      REAL d_t(klon, klev), d_q(klon, klev)
+      REAL d_u(klon, klev), d_v(klon, klev)
+      REAL flux_t(klon,klev), flux_q(klon,klev)
+      REAL dflux_t(klon), dflux_q(klon)
+      REAL flux_u(klon,klev), flux_v(klon,klev)
+      REAL rugmer(klon)
+      REAL cdragh(klon), cdragm(klon)
+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 rugos(klon,nbsrf)
+cAA
+      REAL zcoefh(klon,klev)
+      REAL zu1(klon)
+      REAL zv1(klon)
+cAA
+c======================================================================
+      EXTERNAL clqh, clvent, coefkz, calbeta, cltrac
+c======================================================================
+      REAL yts(klon), yrugos(klon), ypct(klon)
+      REAL ycal(klon), ybeta(klon), ydif(klon)
+      REAL yu1(klon), yv1(klon)
+      REAL yrugm(klon), yrads(klon)
+      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 ygamt(klon,2:klev) ! contre-gradient pour temperature
+      REAL ygamq(klon,2:klev) ! contre-gradient pour humidite
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      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 ok_nonloc
+      PARAMETER (ok_nonloc=.FALSE.)
+      REAL y_cd_h(klon), y_cd_m(klon)
+      REAL ycoefm0(klon,klev), ycoefh0(klon,klev)
+c
+#include "YOMCST.h"
+      REAL u1lay(klon), v1lay(klon)
+      REAL delp(klon,klev)
+      REAL capsol(klon), beta(klon), dif_grnd(klon)
+      REAL cal(klon)
+      REAL soilcap(klon,nbsrf), soilflux(klon,nbsrf)
+      REAL totalflu(klon)
+      INTEGER i, k, nsrf 
+cAA   INTEGER it
+      INTEGER ni(klon), knon, j
+c======================================================================
+      REAL zx_alf1, zx_alf2 !valeur ambiante par extrapola.
+c======================================================================
+      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
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         d_ts(i,nsrf) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         flux_t(i,k) = 0.0
+         flux_q(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         flux_u(i,k) = 0.0
+         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
+      DO 99999 nsrf = 1, nbsrf
+c
+c prescrire les proprietes du sol:
+      CALL calbeta(dtime,nsrf,snow,qsol, beta,capsol,dif_grnd)
+      IF (.NOT.soil_model) THEN
+         DO i = 1, klon
+            cal(i) = RCPD * capsol(i)
+            totalflu(i) = radsol(i)
+         ENDDO
+      ELSE
+         DO i = 1, klon
+            totalflu(i) = soilflux(i,nsrf) + radsol(i)
+            IF (nsrf.EQ.is_oce) THEN
+               cal(i) = 0.0
+            ELSE
+               cal(i) = RCPD / soilcap(i,nsrf)
+            ENDIF
+         ENDDO
+      ENDIF
+c
+c chercher les indices:
+      DO j = 1, klon
+         ni(j) = 0
+      ENDDO
+      knon = 0
+      DO i = 1, klon
+      IF (pctsrf(i,nsrf).GT.epsfra) THEN
+         knon = knon + 1
+         ni(knon) = i
+      ENDIF
+      ENDDO
+c
+      IF (knon.EQ.0) GOTO 99999
+      DO j = 1, knon
+      i = ni(j)
+        ypct(j) = pctsrf(i,nsrf)
+        yts(j) = ts(i,nsrf)
+        yrugos(j) = rugos(i,nsrf)
+        yu1(j) = u1lay(i)
+        yv1(j) = v1lay(i)
+        yrads(j) = totalflu(i)
+        ycal(j) = cal(i)
+        ybeta(j) = beta(i)
+        ydif(j) = dif_grnd(i)
+        ypaprs(j,klev+1) = paprs(i,klev+1)
+      ENDDO
+      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
+cAA      IF (itr.GE.1) THEN
+cAA      DO it = 1, itr
+cAA        DO k = 1, klev
+cAA        DO j = 1, knon
+cAA        i = ni(j)
+cAA          ytr(j,k,it) = tr(i,k,it)
+cAA        ENDDO
+cAA        ENDDO
+cAA        DO j = 1, knon
+cAA        i = ni(j)
+cAA          yflxsrf(j,it) = flux_surf(i,it)
+cAA        ENDDO
+cAA      ENDDO
+cAA      ENDIF
+c
+c calculer Cdrag et les coefficients d'echange
+      CALL coefkz(nsrf, knon, ypaprs, ypplay,
+     .            yts, yrugos, yu, yv, yt, yq,
+     .            ycoefm, ycoefh)
+c
+c parametrisation non-locale:
+      IF (ok_nonloc) THEN
+         DO i = 1, knon
+            y_cd_h(i) = ycoefh(i,1)
+            y_cd_m(i) = ycoefm(i,1)
+         ENDDO
+         CALL nonlocal(knon, ypaprs, ypplay,
+     .        yts,ybeta,yu,yv,yt,yq,
+     .        y_cd_h, y_cd_m, ycoefm0, ycoefh0, ygamt, ygamq)
+         DO k = 1, klev
+         DO i = 1, knon
+            ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+            ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+         ENDDO
+         ENDDO
+      ELSE
+         DO k = 3, klev
+         DO i = 1, knon
+            ygamq(i,k) = 0.0
+            ygamt(i,k) = -1.0E-03
+         ENDDO
+         ENDDO
+         DO i = 1, knon
+            ygamq(i,2) = 0.0
+            ygamt(i,2) = -2.5E-03
+         ENDDO
+      ENDIF
+c
+c calculer la diffusion de "q" et de "h"
+      CALL clqh(knon, dtime, yu1, yv1,
+     e          ycoefh,yt,yq,yts,ypaprs,ypplay,ydelp,yrads,
+     e          ycal,ybeta,ydif,ygamt,ygamq,
+     s          y_d_t, y_d_q, y_d_ts, 
+     s          y_flux_t, y_flux_q, y_dflux_t, y_dflux_q)
+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
+c calculer la longueur de rugosite sur ocean
+      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
+c
+cAA MAINTENANT DANS PHYTRAC
+cAAc calculer la diffusion des traceurs
+cAA      IF (itr.GE.1) THEN
+cAA      DO it = 1, itr
+cAA      CALL cltrac(knon,dtime,ycoefh, yt, ytr(1,1,it), yflxsrf(1,it),
+cAA     e            ypaprs, ypplay, ydelp,
+cAA     s            y_d_tr(1,1,it))
+cAA      ENDDO
+cAA      ENDIF
+c
+      DO j = 1, knon
+         y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+         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
+         ycoefh(j,k) = ycoefh(j,k) * ypct(j)
+         ycoefm(j,k) = ycoefm(j,k) * ypct(j)
+         y_d_t(j,k) = y_d_t(j,k) * ypct(j)
+         y_d_q(j,k) = y_d_q(j,k) * ypct(j)
+         y_flux_t(j,k) = y_flux_t(j,k) * ypct(j)
+         y_flux_q(j,k) = y_flux_q(j,k) * ypct(j)
+         y_d_u(j,k) = y_d_u(j,k) * ypct(j)
+         y_d_v(j,k) = y_d_v(j,k) * ypct(j)
+         y_flux_u(j,k) = y_flux_u(j,k) * ypct(j)
+         y_flux_v(j,k) = y_flux_v(j,k) * ypct(j)
+      ENDDO
+      ENDDO
+c
+      DO j = 1, knon
+      i = ni(j)
+         d_ts(i,nsrf) = y_d_ts(j)
+         rugmer(i) = yrugm(j)
+         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)
+      ENDDO
+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)
+         flux_t(i,k) = flux_t(i,k) + y_flux_t(j,k)
+         flux_q(i,k) = flux_q(i,k) + y_flux_q(j,k)
+         d_u(i,k) = d_u(i,k) + y_d_u(j,k)
+         d_v(i,k) = d_v(i,k) + y_d_v(j,k)
+         flux_u(i,k) = flux_u(i,k) + y_flux_u(j,k)
+         flux_v(i,k) = flux_v(i,k) + y_flux_v(j,k)
+         zcoefh(i,k) = zcoefh(i,k) + ycoefh(j,k)
+      ENDDO
+      ENDDO
+c
+cAA      IF (itr.GE.1) THEN
+cAA      DO it = 1, itr
+cAA      DO k = 1, klev
+cAA      DO j = 1, knon
+cAA         y_d_tr(j,k,it) = y_d_tr(j,k,it) * ypct(j)
+cAA      ENDDO
+cAA      ENDDO
+cAA      ENDDO
+cAA      DO j = 1, knon
+cAA      i = ni(j)
+cAA      DO it = 1, itr
+cAA      DO k = 1, klev
+cAA         d_tr(i,k,it) = d_tr(i,k,it) + y_d_tr(j,k,it)
+cAA      ENDDO
+cAA      ENDDO
+cAA      ENDDO
+cAA      ENDIF
+c
+99999 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE clqh(knon,dtime,u1lay,v1lay,coef,t,q,ts,paprs,pplay,
+     e                delp,radsol,cal,beta,dif_grnd, gamt,gamq,
+     s                d_t, d_q, d_ts, flux_t, flux_q,dflux_s,dflux_l)
+      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"
+c Arguments:
+      INTEGER knon
+      REAL dtime              ! intervalle du temps (s)
+      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 cal(klon)          ! Cp/cal indique la capacite calorifique
+c                               surfacique du sol
+      REAL beta(klon)         ! evap. reelle / evapotranspiration
+      REAL dif_grnd(klon)     ! coeff. diffusion vers le sol profond
+      REAL t(klon,klev)       ! temperature (K)
+      REAL q(klon,klev)       ! humidite specifique (kg/kg)
+      REAL ts(klon)           ! temperature du sol (K)
+      REAL 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
+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
+      REAL dflux_g(klon) ! derivee du flux du sol profond 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_a
+      REAL zx_b
+      REAL zx_qs
+      REAL zx_dq_s_dh
+      REAL zx_h_grnd
+      REAL zx_cq0(klon)
+      REAL zx_dq0(klon)
+      REAL zx_cq(klon,klev)
+      REAL zx_dq(klon,klev)
+      REAL zx_ch(klon,klev)
+      REAL zx_dh(klon,klev)
+      REAL zx_buf1(klon)
+      REAL zx_buf2(klon)
+      REAL zx_coef(klon,klev)
+      REAL zx_q_0(klon)
+      REAL zx_h_ts(klon)
+      REAL zx_sl(klon)
+      REAL local_h(klon,klev) ! enthalpie potentielle
+      REAL local_q(klon,klev)
+      REAL local_ts(klon)
+      REAL zx_alf1(klon), zx_alf2(klon) !valeur ambiante par extrapola.
+      REAL psref(klon) ! pression de reference pour temperature potent.
+      REAL zx_pkh(klon,klev), zx_pkf(klon,klev)
+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======================================================================
+      REAL zcor, zdelta, zcvm5
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c======================================================================
+      DO i = 1, knon
+         psref(i) = paprs(i,1) !pression de reference est celle au sol
+         local_ts(i) = ts(i)
+ccc         zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+         zx_alf1(i) = 1.0
+         zx_alf2(i) = 1.0 - zx_alf1(i)
+      ENDDO
+      DO k = 1, klev
+      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
+      DO i = 1, knon
+         zx_coef(i,1) = coef(i,1)
+     .                 * (1.0+SQRT(u1lay(i)**2+v1lay(i)**2))
+     .                 * pplay(i,1)/(RD*t(i,1))
+         zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+      ENDDO
+c
+      DO k = 2, klev
+      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
+c======================================================================
+      DO i = 1, knon
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,rtt-local_ts(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+           zx_qs= r2es * FOEEW(local_ts(i),zdelta)/paprs(i,1)
+           zx_qs=MIN(0.5,zx_qs)
+           zcor=1./(1.-retv*zx_qs)
+           zx_qs=zx_qs*zcor
+           zx_dq_s_dh = FOEDE(local_ts(i),zdelta,zcvm5,zx_qs,zcor)
+     .                 /RLVTT / zx_pkh(i,1)
+         ELSE
+           IF (local_ts(i).LT.t_coup) THEN
+              zx_qs = qsats(local_ts(i)) / paprs(i,1)
+              zx_dq_s_dh = dqsats(local_ts(i),zx_qs)/RLVTT
+     .                    / zx_pkh(i,1)
+           ELSE
+              zx_qs = qsatl(local_ts(i)) / paprs(i,1)
+              zx_dq_s_dh = dqsatl(local_ts(i),zx_qs)/RLVTT
+     .                    / zx_pkh(i,1)
+           ENDIF
+         ENDIF
+c
+         zx_dq0(i) = zx_dq_s_dh
+         zx_cq0(i) = zx_qs -zx_dq_s_dh *local_ts(i)*RCPD*zx_pkh(i,1)
+      ENDDO
+      DO i = 1, knon
+         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
+         zx_buf2(i) = delp(i,klev) + zx_coef(i,klev)
+         zx_ch(i,klev) = (local_h(i,klev)*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
+         zx_buf2(i) = 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)*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
+      DO i = 1, knon
+         zx_buf1(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dq(i,2))
+     .              + zx_coef(i,1)*beta(i)
+     .                *(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
+         zx_cq(i,1) = (local_q(i,1)*delp(i,1)
+     .                 +zx_coef(i,2)*z_gamaq(i,2)
+     .                 +zx_cq(i,2)*(zx_coef(i,2)
+     .                  -zx_coef(i,1)*zx_alf2(i)*beta(i)) )
+     .                /zx_buf1(i)
+         zx_dq(i,1) = beta(i) * zx_coef(i,1) / zx_buf1(i)
+c
+         zx_buf2(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dh(i,2))
+     .               +zx_coef(i,1)
+     .                *(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))
+         zx_ch(i,1) = (local_h(i,1)*delp(i,1)
+     .                 +zx_coef(i,2)*z_gamah(i,2)
+     .                 +zx_ch(i,2)*(zx_coef(i,2)
+     .                  -zx_coef(i,1)*zx_alf2(i)) )
+     .                /zx_buf2(i)
+         zx_dh(i,1) = zx_coef(i,1) / zx_buf2(i)
+      ENDDO
+c==== calculer d'abord local_h(0) ============================
+      DO i = 1, knon
+         zx_sl(i) = RLVTT
+         if (local_ts(i) .LT. RTT) zx_sl(i) = RLSTT
+      ENDDO
+      DO i = 1, knon
+         zx_h_grnd = t_grnd * zx_pkh(i,1) *RCPD
+         zx_h_ts(i) = local_ts(i) * zx_pkh(i,1) *RCPD
+         zx_a = radsol(i)
+     .        + zx_coef(i,1)/(RG*dtime)*beta(i)*zx_sl(i)
+     .          *(zx_cq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
+     .            +zx_alf2(i)*zx_cq(i,2))
+     .        + zx_coef(i,1)/(RG*dtime)*beta(i)*zx_sl(i)
+     .          *((zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))
+     .             -1.0)*zx_cq0(i))
+     .        + zx_coef(i,1)/(RG*dtime)/zx_pkh(i,1)
+     .          *(zx_ch(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))
+     .           +zx_alf2(i)*zx_ch(i,2))
+         zx_a = zx_h_ts(i) + dif_grnd(i)*dtime*zx_h_grnd
+     .                     + cal(i)*zx_pkh(i,1)*dtime * zx_a 
+         zx_b = zx_coef(i,1)/(RG*dtime) *beta(i)*zx_sl(i)*zx_dq0(i)
+     .          *(1.0-zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2)))
+     .        + zx_coef(i,1)/(RG*dtime)/zx_pkh(i,1)
+     .          *(1.0-zx_dh(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2)))
+         zx_b = 1.0 + dif_grnd(i)*dtime + cal(i)*zx_pkh(i,1)*dtime*zx_b
+         zx_h_ts(i) = zx_a / zx_b
+         local_ts(i) = zx_h_ts(i) / zx_pkh(i,1)/RCPD
+      ENDDO
+c==== une fois on a zx_h_ts, on peut faire l'iteration ========
+      DO i = 1, knon
+         zx_q_0(i) = zx_cq0(i) + zx_dq0(i)*zx_h_ts(i)
+      ENDDO
+      DO i = 1, knon
+         local_h(i,1) = zx_ch(i,1) + zx_dh(i,1)*zx_h_ts(i)
+         local_q(i,1) = zx_cq(i,1) + zx_dq(i,1)*zx_q_0(i)
+      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 i = 1, knon
+        flux_q(i,1) = (zx_coef(i,1)/dtime/RG) * beta(i)
+     .              * (local_q(i,1)*zx_alf1(i)
+     .                +local_q(i,2)*zx_alf2(i)-zx_q_0(i))
+        flux_t(i,1) = (zx_coef(i,1)/dtime/RG)
+     .              * (local_h(i,1)*zx_alf1(i)
+     .                +local_h(i,2)*zx_alf2(i)-zx_h_ts(i))
+     .              / zx_pkh(i,1)
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, knon
+        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 Derives des flux dF/dTs (W m-2 K-1):
+      DO i = 1, knon
+         dflux_s(i) = (RCPD*zx_coef(i,1))/(RG*dtime)/zx_pkh(i,1)
+     .         *(zx_dh(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dh(i,2))-1.0)
+         dflux_l(i) = (beta(i)*RLVTT*RCPD*zx_coef(i,1))/(RG*dtime)
+     .         *zx_dq0(i)
+     .         *(zx_dq(i,1)*(zx_alf1(i)+zx_alf2(i)*zx_dq(i,2))-1.0)
+         dflux_g(i) = dif_grnd(i) * RCPD
+      ENDDO
+c======================================================================
+      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
+      DO i = 1, knon
+         d_ts(i) = local_ts(i) - ts(i)
+      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 xlat-----input-R- latitude en degree
+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)
+      REAL xlat(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.35)
+      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.2)
+      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-06)
+      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 zcfm1(klon), zcfm2(klon)
+      REAL zcfh1(klon), zcfh2(klon)
+      REAL zdphi, zdu2, ztvd, ztvu, ztsolv, zcdn
+      REAL zscf, zucf, zcr
+      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
+      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
+c
+c Prescrire la valeur de contre-gradient
+c
+      IF (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
+      DO i = 1, knon
+         zdu2=max(cepdu2,u(i,1)**2+v(i,1)**2)
+         zdphi=zgeop(i,1)
+         ztsolv = ts(i) * (1.0+RETV*q(i,1)) ! qsol approx = q(i,1)
+         ztvd=(t(i,1)+zdphi/RCPD/(1.+RVTMP2*q(i,1)))
+     .       *(1.+RETV*q(i,1))
+         zri(i)=zgeop(i,1)*(ztvd-ztsolv)/(zdu2*ztvd)
+         zcdn = (ckap/log(1.+zgeop(i,1)/(RG*rugos(i))))**2
+         IF (zri(i) .ge. 0.) THEN ! situation stable
+           IF (.NOT.zxli) THEN
+           zscf=SQRT(1.+cd*ABS(zri(i)))
+           zcfm1(i) = zcdn/(1.+2.0*cb*zri(i)/zscf)
+           zcfh1(i) = zcdn/(1.+3.0*cb*zri(i)*zscf)
+           pcfm(i,1) = zcfm1(i)
+           pcfh(i,1) = zcfh1(i)
+           ELSE
+           pcfm(i,1) = zcdn* fsta(zri(i))
+           pcfh(i,1) = zcdn* fsta(zri(i))
+           ENDIF
+         ELSE ! situation instable
+           IF (.NOT.zxli) THEN
+           zucf=1./(1.+3.0*cb*cc*zcdn*SQRT(ABS(zri(i))
+     .              *(1.0+zgeop(i,1)/(RG*rugos(i)))))
+           zcfm2(i) = zcdn*(1.-2.0*cb*zri(i)*zucf)
+           zcfh2(i) = zcdn*(1.-3.0*cb*zri(i)*zucf)
+           pcfm(i,1) = zcfm2(i)
+           pcfh(i,1) = zcfh2(i)
+           ELSE
+           pcfm(i,1) = zcdn* fins(zri(i))
+           pcfh(i,1) = zcdn* fins(zri(i))
+           ENDIF
+           zcr = (0.0016/(zcdn*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+           IF(nsrf.EQ.is_oce)pcfh(i,1)=zcdn*(1.0+zcr**1.25)**(1./1.25)
+         ENDIF
+      ENDDO
+c
+c Calculer les coefficients turbulents dans l'atmosphere
+c
+      DO i = 1, knon
+         itop(i) = isommet
+      ENDDO
+
+      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 calbeta(dtime,indice,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
+      PARAMETER (tau_gl=86400.0*30.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,nbsrf), qsol(klon,nbsrf)
+      INTEGER indice
+C
+      REAL vbeta(klon)
+      REAL vcal(klon)
+      REAL vdif(klon)
+C
+      IF (indice.EQ.is_oce) THEN
+      DO i = 1, klon
+          vcal(i)   = 0.0
+          vbeta(i)  = 1.0
+          vdif(i) = 0.0
+      ENDDO
+      ENDIF
+c
+      IF (indice.EQ.is_sic) THEN
+      DO i = 1, klon
+          vcal(i) = calice
+          IF (snow(i,is_sic) .GT. 0.0) vcal(i) = calsno
+          vbeta(i)  = 1.0
+ccc          vdif(i) = 1.0/tau_gl ! c'etait une erreur
+          vdif(i) = calice/tau_gl
+      ENDDO
+      ENDIF
+c
+      IF (indice.EQ.is_ter) THEN
+      DO i = 1, klon
+          vcal(i) = calsol
+          IF (snow(i,is_ter) .GT. 0.0) vcal(i) = calsno
+          vbeta(i)  = MIN(2.0*qsol(i,is_ter)/mx_eau_sol, 1.0)
+          vdif(i) = 0.0
+      ENDDO
+      ENDIF
+c
+      IF (indice.EQ.is_lic) THEN
+      DO i = 1, klon
+          vcal(i) = calice
+          IF (snow(i,is_lic) .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.35)
+      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/branches/LF/libf/phylmd/cltrac.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/cltrac.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/cltrac.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/cltracrn.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/cltracrn.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/cltracrn.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/conccm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/conccm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/conccm.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/condsurf.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/condsurf.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/condsurf.F	(revision 3)
@@ -0,0 +1,350 @@
+      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=.FALSE.)
+
+      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 Couplage OASIS:
+#include "oasis.h"
+      REAL cpl_sst(iim,jjm+1), cpl_sic(iim,jjm+1)
+      REAL cpl_alb_sst(iim,jjm+1), cpl_alb_sic(iim,jjm+1)
+c
+c Variables locales:
+      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  = anne_ini
+       anneemax  = anne_ini + 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', anne_ini
+           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 Fraction "ocean":
+      ierr = NF_INQ_VARID (nid, "FOCE", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <FOCE> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_oce))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_oce))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <FOCE>"
+         CALL abort
+      ENDIF
+c
+c Fraction "glace de mer":
+      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 Fraction "terre":
+      ierr = NF_INQ_VARID (nid, "FTER", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <FTER> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_ter))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_ter))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Lecture echouee pour <FTER>"
+         CALL abort
+      ENDIF
+c
+c Fraction "glacier terre":
+      ierr = NF_INQ_VARID (nid, "FLIC", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "condsurf: Le champ <FLIC> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,nvarid,debut,epais,pctsrf(1,is_lic))
+#else
+      ierr = NF_GET_VARA_REAL(nid,nvarid,debut,epais,pctsrf(1,is_lic))
+#endif
+      IF (ierr .NE. 0) THEN
+         PRINT*, "condsurf: Lecture echouee pour <FLIC>"
+         CALL abort
+      ENDIF
+c
+      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
+      IF (ok_oasis) THEN
+C
+         CALL fromcpl(jour,(jjm+1)*iim,
+     .        cpl_sst,cpl_sic,cpl_alb_sst,cpl_alb_sic)
+         DO i = 1, iim-1 ! un seul point pour le pole nord
+            cpl_sst(i,1) = cpl_sst(iim,1)
+            cpl_sic(i,1) = cpl_sic(iim,1)
+            cpl_alb_sst(i,1) = cpl_alb_sst(iim,1)
+            cpl_alb_sic(i,1) = cpl_alb_sic(iim,1)
+         ENDDO
+         DO i = 2, iim ! un seul point pour le pole sud
+            cpl_sst(i,jjm+1) = cpl_sst(1,jjm+1)
+            cpl_sic(i,jjm+1) = cpl_sic(1,jjm+1)
+            cpl_alb_sst(i,jjm+1) = cpl_alb_sst(1,jjm+1)
+            cpl_alb_sic(i,jjm+1) = cpl_alb_sic(1,jjm+1)
+         ENDDO
+c
+         ig = 1
+         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
+     .       pctsrf(ig,is_sic).GT.epsfra) THEN
+            pctsrf(ig,is_oce) = pctsrf(ig,is_oce)
+     .                        - (cpl_sic(1,1)-pctsrf(ig,is_sic))
+            pctsrf(ig,is_sic) = cpl_sic(1,1)
+            lmt_sst(ig) = cpl_sst(1,1)
+         ENDIF
+         DO j = 2, jjm
+         DO i = 1, iim
+         ig = ig + 1
+         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
+     .       pctsrf(ig,is_sic).GT.epsfra) THEN
+           pctsrf(ig,is_oce) = pctsrf(ig,is_oce) 
+     .                       - (cpl_sic(i,j)-pctsrf(ig,is_sic))
+           pctsrf(ig,is_sic) = cpl_sic(i,j)
+           lmt_sst(ig) = cpl_sst(i,j)
+         ENDIF
+         ENDDO
+         ENDDO
+         ig = ig + 1
+         IF (pctsrf(ig,is_oce).GT.epsfra .OR.
+     .       pctsrf(ig,is_sic).GT.epsfra) THEN
+            pctsrf(ig,is_oce) = pctsrf(ig,is_oce)
+     .                        - (cpl_sic(1,jjm+1)-pctsrf(ig,is_sic))
+            pctsrf(ig,is_sic) = cpl_sic(1,jjm+1)
+            lmt_sst(ig) = cpl_sst(1,jjm+1)
+         ENDIF
+c
+      ENDIF ! ok_oasis
+c
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/conflx.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/conflx.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/conflx.F	(revision 3)
@@ -0,0 +1,1609 @@
+      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)
+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
+         pmflxr(i,k) = 0.0
+         pmflxs(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, pmflxr, pmflxs)
+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
+
+c
+      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.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
+      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)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, i
+      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)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)-pdpmel(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
+      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)
+            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
+      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 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/branches/LF/libf/phylmd/conlmd.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/conlmd.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/conlmd.F	(revision 3)
@@ -0,0 +1,2290 @@
+      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=5)
+ccc      PARAMETER (nb=3)
+c
+      REAL ratqs ! largeur de la distribution pour vapeur d'eau
+      PARAMETER (ratqs=0.2)
+c
+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.75, 0.50, 0.25, 0.05 /
+ccc      DATA opt_cld / 3,   3,    3,    3,    3 /
+ccc      DATA frac    / 1.0, 0.50, 0.25/
+ccc      DATA opt_cld / 3,   3,    3/
+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 .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=.FALSE.)
+      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.1, tomax=0.2)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.6, tomin=0.1)
+      LOGICAL exigent ! implique un calcul supplementaire pour Qs
+      PARAMETER (exigent=.FALSE.)
+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) = 0
+         k2(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 (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 = 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.1) THEN
+         k = k1(i)
+         zflo(i) = zt(i,k-1) + zgamdz(i,k-1) - zt(i,k)
+         zsat(i) = zqmqsdp(i,k) + zqmqsdp(i,k-1)
+         IF (zflo(i).LE.0.0 .OR. zsat(i).LE.0.0) THEN
+            etendre(i) = .TRUE.
+            k1(i) = k1(i) - 1
+            k1max = MAX(k1max,k1(i))
+            aller(i) = .TRUE.
+         ENDIF
+      ENDIF
+      ENDDO
+c
+      IF (k1max.GT.1) THEN
+      DO k = k1max, 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=.FALSE.)
+      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.1, tomax=0.2)
+      REAL dpmax, tomin !Epaisseur grande, rapport eau liquide plus faible
+      PARAMETER (dpmax=0.6, tomin=0.1)
+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 (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 = 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 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/branches/LF/libf/phylmd/dimphy.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/dimphy.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/dimphy.h	(revision 3)
@@ -0,0 +1,8 @@
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
+     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
+c-----------------------------------------------------------------------
+      INTEGER nbtr ! nombre de vrais traceurs
+      PARAMETER (nbtr=nqmx-2+1/(nqmx-1))
+c-----------------------------------------------------------------------
Index: LMDZ.3.3/branches/LF/libf/phylmd/dimsoil.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/dimsoil.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/dimsoil.h	(revision 3)
@@ -0,0 +1,2 @@
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: LMDZ.3.3/branches/LF/libf/phylmd/ecribin.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/ecribin.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/ecribin.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/ecrireg.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/ecrireg.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/ecrireg.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/fisrtilp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp.F	(revision 3)
@@ -0,0 +1,293 @@
+      SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow)
+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"
+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)
+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.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 ! 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
+      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 Fonctions en ligne:
+c
+      REAL fallv ! vitesse de chute pour crystaux de glace
+      REAL zzz
+#include "YOETHF.h"
+#include "FCTTRE.h"
+CCC      fallv (zzz) = 3.29/3.0 * ((zzz)**0.
+       fallv (zzz) = 3.29 * ((zzz)**0.16)
+c
+      DATA appel1er /.TRUE./
+c
+      IF (appel1er) THEN
+         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.
+      ENDIF
+c
+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
+      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
+      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 Boucle verticale (du haut vers le bas)
+c
+      DO 9999 k = klev, 1, -1
+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
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs = zx * (rat_max-rat_min) + rat_min
+            IF (.NOT.calcrat) ratqs=0.2
+c
+            zdelq = ratqs * zq(i)
+            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
+      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
+ 9999 CONTINUE
+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/branches/LF/libf/phylmd/fisrtilp_tr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp_tr.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/fisrtilp_tr.F	(revision 3)
@@ -0,0 +1,400 @@
+      SUBROUTINE fisrtilp_tr(dtime,paprs,pplay,t,q,
+     s                   d_t, d_q, d_ql, rneb, radliq, rain, snow,
+     s                   pfrac_impa, pfrac_nucl, pfrac_1nucl,
+     s                   frac_impa, frac_nucl )
+
+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)
+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.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 ! determine la largeur de distribution de vapeur
+      PARAMETER (calcrat=.FALSE.)
+      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
+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 * ((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
+      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.
+      zprec_cond  = 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
+            zx = pplay(i,k)/paprs(i,1)
+            zx = (zx_max-zx)/(zx_max-zx_min)
+            zx = MIN(MAX(zx,0.0),1.0)
+            zx = zx * zx * zx
+            ratqs = zx * (rat_max-rat_min) + rat_min
+            IF (.NOT.calcrat) ratqs=0.2
+c
+            zdelq = ratqs * zq(i)
+            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
+      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 = MAX(zcond(i)-zoliq(i),0.0)
+     .                * (paprs(i,k)-paprs(i,k+1))/RG
+         IF (rneb(i,k).GT.0.0.and.zprec_cond.gt.0.) THEN
+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/zneb(i))
+            pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+            frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+c
+c nucleation avec un facteur -1 au lieu de -0.5
+            zfrac_lessi = 1. - EXP(-zprec_cond/zneb(i))
+            pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+cAA Lessivage par impaction dans les couches en-dessous
+            do kk=k-1,1,-1
+              if (t(i,kk) .GE. ztglace) THEN
+                 zalpha_tr = a_tr_sca(1)
+              else
+                 zalpha_tr = a_tr_sca(2)
+              endif
+              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond/zneb(i))
+              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi 
+            enddo
+         ENDIF
+c
+      ENDDO      ! boucle sur i
+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/branches/LF/libf/phylmd/flxtr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/flxtr.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/flxtr.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/hgardfou.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/hgardfou.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/hgardfou.F	(revision 3)
@@ -0,0 +1,113 @@
+      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
+            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
+            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/branches/LF/libf/phylmd/homogene.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/homogene.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/homogene.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/hydrol.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/hydrol.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/hydrol.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/indicesol.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/indicesol.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/indicesol.h	(revision 3)
@@ -0,0 +1,14 @@
+      INTEGER nbsrf
+      PARAMETER (nbsrf=4) ! nombre de sous-fractions pour une maille
+c
+      INTEGER is_oce
+      PARAMETER (is_oce=1) ! ocean
+      INTEGER is_sic
+      PARAMETER (is_sic=2) ! glace de mer
+      INTEGER is_ter
+      PARAMETER (is_ter=3) ! terre
+      INTEGER is_lic
+      PARAMETER (is_lic=4) ! glacier continental
+c
+      REAL epsfra
+      PARAMETER (epsfra=1.0E-05)
Index: LMDZ.3.3/branches/LF/libf/phylmd/inifis.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/inifis.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/inifis.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/initrrnpb.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/initrrnpb.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/initrrnpb.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/minmaxqfi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/minmaxqfi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/minmaxqfi.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/nflxtr.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/nflxtr.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/nflxtr.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/nuage.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/nuage.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/nuage.F	(revision 3)
@@ -0,0 +1,290 @@
+      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"
+      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_froid, rad_chaud
+      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
+         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 diagcld(paprs,pplay,t,q,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 Options a choisir:
+      LOGICAL ok_conv ! prendre en compte les nuages convectifs
+      PARAMETER (ok_conv=.TRUE.)
+      LOGICAL ok_inve ! prendre en compte les nuages d'inversion
+CCC      PARAMETER (ok_inve=.TRUE.)
+      PARAMETER (ok_inve=.FALSE.)
+c
+c Constantes ajustables:
+      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)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+ccc      PARAMETER (CRHL=0.15)
+      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zcc(klon), zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+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
+      IF (ok_conv) THEN
+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
+cn
+      DO i = 1, klon ! pour traiter les enclumes
+         diafra(i,ktop(i)) = zcc(i) * CCFCT
+ccc      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.
+     .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
+     .   diafra(i,ktop(i)) = MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB))      
+cc     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+cc     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      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)=zcc(i)*CCFCT
+cc         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      ENDIF ! ok_conv
+c
+      IF (ok_inve) THEN
+
+      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))
+cc         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+cc         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+         diafra(i,kb) = zcll
+         dialiq(i,kb)= zcll* RGAMMAS*zqs        
+      ENDDO
+c
+      ENDIF ! ok_inve
+c
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/o3cm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/o3cm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/o3cm.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/oasis.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/oasis.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/oasis.F	(revision 3)
@@ -0,0 +1,1308 @@
+      SUBROUTINE inicma(kastp,kexch,kstep)
+      IMPLICIT none
+c
+      INTEGER kastp, kexch, kstep
+c
+      INTEGER ime
+      PARAMETER (ime = 1)
+c
+C****
+C               *****************
+C               * OASIS ROUTINE *
+C               * ------------- *
+C               *****************
+C
+C**** *INICMA*  - Initialize coupled mode communication for atmosphere
+C
+C     Purpose:
+C     -------
+C     Exchange process identifiers and timestep information
+C     between AGCM, OGCM and COUPLER.
+C
+C     Input:
+C     -----
+C       KASTP  : total number of timesteps in atmospheric model
+C       KEXCH  : frequency of exchange (in time steps)
+C       KSTEP  : timestep value (in seconds)
+C
+C     Method:
+C     ------
+C     Use named pipes(FIFO) to exchange process identifiers
+C     between the programs
+C
+C     Externals:
+C     ---------
+C     GETPID, MKNOD
+C
+C     Reference:
+C     ---------
+C     See Epicoa 0803 (1992)
+C
+C     Author:
+C     -------
+C     Laurent Terray  92-09-01
+C
+C     -----------------------------------------------------------
+C
+      INTEGER imess(4)
+      INTEGER getpid, mknod ! system functions
+      CHARACTER*80 clcmd
+      CHARACTER*8 pipnom, fldnom
+      INTEGER ierror
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "oasis.h"
+#include "clim.h"
+c
+      INTEGER iparal(3)
+      INTEGER istep, ifcpl, idt, info, imxtag
+c
+      INTEGER mode, iret, isize
+C
+      INTEGER nuout
+      PARAMETER (nuout = 6)
+C     -----------------------------------------------------------
+C
+C*    1. Initializations
+C        ---------------
+C
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' ROUTINE INICMA'
+      WRITE(nuout,*) ' **************'
+      WRITE(nuout,*) ' '
+      WRITE(nuout,*) ' '
+c
+      IF (cchain.EQ."PIPE") THEN
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Making pipes for fields to receive from CPL"
+      WRITE(nuout,*) " "
+c
+c zxli(le17fev97): je ne comprends pas pourquoi il faut
+c                  avoir 2 noms pour un seul pipe
+c
+      pipnom = "SISUTESU"
+      fldnom = "Sisutesu"
+#ifdef CRAY
+      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "SIALBEDO"
+      fldnom = "Sialbedo"
+#ifdef CRAY
+      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "SIICECOV"
+      fldnom = "Siicecov"
+#ifdef CRAY
+      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "SIICEALB"
+      fldnom = "Siicealb"
+#ifdef CRAY
+      clcmd = "assign -s unblocked -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Making pipes for fields to send to CPL"
+      WRITE(nuout,*) " "
+c
+      pipnom = "CONSFTOT"
+      fldnom = "Consftot"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COSSTSST"
+      fldnom = "Cosstsst"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "CODFLXDT"
+      fldnom = "Codflxdt"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COSHFTOT"
+      fldnom = "Coshftot"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COALBSUR"
+      fldnom = "Coalbsur"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COTOSPSU"
+      fldnom = "Cotospsu"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COTOLPSU"
+      fldnom = "Cotolpsu"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COTFSHSU"
+      fldnom = "Cotfshsu"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "CORUNCOA"
+      fldnom = "Coruncoa"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "CORIVFLU"
+      fldnom = "Corivflu"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COZOTAUX"
+      fldnom = "Cozotaux"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COMETAUY"
+      fldnom = "Cometauy"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COZOTAU2"
+      fldnom = "Cozotau2"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      pipnom = "COMETAU2"
+      fldnom = "Cometau2"
+#ifdef CRAY
+      clcmd = "assign -s u -a "//pipnom//" f:"//fldnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+      WRITE(nuout,'(a80)') clcmd
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+      WRITE(nuout,'(a80)') clcmd
+#endif
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "All pipes have been made"
+      WRITE(nuout,*) " "
+      CALL flush(nuout)
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Communication test between ATM and CPL"
+      WRITE(nuout,*) " "
+c
+      WRITE (pipnom,'(a6,i2.2)') "Preadm", ime
+#ifdef CRAY
+      clcmd = "assign -s u f:"//pipnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+#endif
+      WRITE(nuout,'(a80)') clcmd
+      imess(1) = kastp
+      imess(2) = kexch
+      imess(3) = kstep
+      imess(4) = getpid()
+#ifdef CRAY
+      WRITE (pipnom) imess ! send message to pipe
+#else
+      iret=0
+      isize=4
+      CALL pipwrite(pipnom, imess, isize, iret)
+#endif
+      WRITE(nuout,*) "Msg sent to pipe "//pipnom
+      CALL flush(nuout)
+c
+      WRITE (pipnom,'(a6,i2.2)') "Pwritm", ime
+#ifdef CRAY
+      clcmd = "assign -s unblocked f:"//pipnom
+      CALL assign(clcmd, ierror)
+      ierror = mknod (pipnom, 4480, 0)
+#else
+      clcmd = "CALL makepipe("//pipnom//",...,...)"
+      mode = o'010600'
+      iret = 0
+      CALL makepipe(pipnom, mode, iret)
+#endif
+      WRITE(nuout,'(a80)') clcmd
+c
+      WRITE(nuout,*) "Waiting for the pipe "//pipnom
+      CALL flush(nuout)
+#ifdef CRAY
+      READ (pipnom) imess ! read message from pipe
+#else
+      isize=1
+      iret =0
+      CALL pipread(pipnom,imess,isize,iret)
+#endif
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Communication test between ATM and CPL is OK"
+      WRITE(nuout,*) " total simulation time in oasis = ", imess(1)
+      WRITE(nuout,*) " total number of iterations is  = ", imess(2)
+      WRITE(nuout,*) " value of oasis timestep  is    = ", imess(3)
+      WRITE(nuout,*) " process id for oasis  is       = ", imess(4)
+      WRITE(nuout,*) " "
+      CALL flush(nuout)
+c
+      ELSE ! cchain.EQ."CLIM"
+c
+      CALL CLIM_Init ( 'CLI', 'lmd.xx', 3, 7,
+     *                 kastp, kexch, kstep,
+     *                 5, 1200, 300, info )
+      IF (info.EQ.CLIM_Ok) THEN
+         WRITE(nuout,*) "inicma: CLIM_Init OK"
+      ELSE
+         WRITE(nuout,*) "inicma: CLIM_Init erreur:", info
+         CALL ABORT("STOP in inicma")
+      ENDIF
+c
+      iparal ( CLIM_Strategy ) = CLIM_Serial
+      iparal ( CLIM_Length   ) = iim*(jjm+1)
+      iparal ( CLIM_Offset   ) = 0
+c
+      CALL CLIM_Define ('SISUTESU', CLIM_In , CLIM_Double, iparal, info)
+      CALL CLIM_Define ('SIALBEDO', CLIM_In , CLIM_Double, iparal, info)
+      CALL CLIM_Define ('SIICECOV', CLIM_In , CLIM_Double, iparal, info)
+      CALL CLIM_Define ('SIICEALB', CLIM_In , CLIM_Double, iparal, info)
+c
+      CALL CLIM_Define ('CONSFTOT', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COSSTSST', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('CODFLXDT', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COSHFTOT', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COALBSUR', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COTOSPSU', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COTOLPSU', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COTFSHSU', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('CORUNCOA', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('CORIVFLU', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COZOTAUX', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COMETAUY', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COZOTAU2', CLIM_Out , CLIM_Double, iparal,info)
+      CALL CLIM_Define ('COMETAU2', CLIM_Out , CLIM_Double, iparal,info)
+      WRITE(nuout,*) 'inicma : CLIM_Define ok '
+c
+      CALL CLIM_Start ( imxtag, info )
+      IF (info.NE.CLIM_Ok) THEN
+          WRITE (nuout,*) "inicma: CLIM_Start pb. ", info
+          CALL ABORT("STOP in inicma")
+      ELSE
+          WRITE (nuout,*)  "inicma: CLIM_Start OK"
+      ENDIF
+c
+      CALL CLIM_Stepi ("oasis", istep, ifcpl, idt, info)
+      IF (info .NE. CLIM_Ok) THEN
+          WRITE (nuout,*) "inicma: CLIM_Stepi pb. ", info
+          CALL ABORT("STOP in inicma")
+      ELSE
+          WRITE (nuout,*) "inicma: CLIM_Stepi OK"
+          WRITE (nuout,*) " number of tstep in oasis ", istep
+          WRITE (nuout,*) " exchange frequency in oasis ", ifcpl
+          WRITE (nuout,*) " length of tstep in oasis ", idt
+      ENDIF
+c
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE fromcpl(jour, imjm, sst, sic, alb_sst, alb_sic)
+      IMPLICIT none
+c
+c Laurent Z.X Li (Feb. 10, 1997): It reads the SST and Sea-Ice
+c provided by the coupler. Of course, it waits until it receives
+c the signal from the corresponding pipes in the case of utilizing
+c the pipe technique.
+c
+      INTEGER imjm, jour
+      REAL sst(imjm)      ! sea surface temperature
+      REAL alb_sst(imjm)  ! open sea albedo
+      REAL sic(imjm)      ! sea ice cover
+      REAL alb_sic(imjm)  ! sea ice albedo
+c
+      INTEGER nuout   ! listing output unit
+      PARAMETER (nuout=6)
+c
+      INTEGER nuread, ios, iflag, icpliter
+      CHARACTER*8 pipnom ! name for the pipe
+      CHARACTER*8 fldnom ! name for the field
+      CHARACTER*8 filnom ! name for the data file
+c
+#include "oasis.h"
+#include "clim.h"
+      INTEGER info, jktm1
+      INTEGER iret, isize
+c
+      WRITE (nuout,*) " "
+      WRITE (nuout,*) "Fromcpl: Read fields from CPL"
+      WRITE (nuout,*) " "
+      CALL flush (nuout)
+c
+      IF (cchain.EQ."PIPE") THEN
+c
+c sea-surface-temperature:
+c
+      pipnom = "Sisutesu"
+      fldnom = "SISUTESU"
+      filnom = "atmsst"
+      WRITE (nuout,*) "Waiting for the pipe "//pipnom
+      CALL flush (nuout)
+#ifdef CRAY
+      READ (pipnom) icpliter
+#else
+      iret = 0
+      isize = 1
+      CALL pipread(pipnom, icpliter, isize, iret)
+#endif
+      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      nuread = 99
+      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(nuout,*) "Error while connecting "//filnom, nuread
+          CALL flush (nuout)
+          CALL ABORT("STOP in Fromcpl")
+      ENDIF
+      REWIND (UNIT = nuread)
+      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      CALL locread(fldnom, sst, imjm, nuread, iflag)
+      IF (iflag .NE. 0) THEN
+          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
+          WRITE(nuout,*) "jour, iflag = ", jour, iflag
+          CALL flush (nuout)
+          CALL ABORT('STOP in Fromcpl')
+      ENDIF
+      CLOSE(nuread)
+      WRITE(nuout,*) "Succesful for reading "//fldnom
+      CALL flush (nuout)
+c
+c open sea albedo:
+c
+      pipnom = "Sialbedo"
+      fldnom = "SIALBEDO"
+      filnom = "atmice"
+      WRITE (nuout,*) "Waiting for the pipe "//pipnom
+      CALL flush (nuout)
+#ifdef CRAY
+      READ (pipnom) icpliter
+#else
+      iret = 0
+      isize = 1
+      CALL pipread(pipnom, icpliter, isize, iret)
+#endif
+      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      nuread = 99
+      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(nuout,*) "Error while connecting "//filnom, nuread
+          CALL flush (nuout)
+          CALL ABORT("STOP in Fromcpl")
+      ENDIF
+      REWIND (UNIT = nuread)
+      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      CALL locread(fldnom, alb_sst, imjm, nuread, iflag)
+      IF (iflag .NE. 0) THEN
+          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
+          WRITE(nuout,*) "jour, iflag = ", jour, iflag
+          CALL flush (nuout)
+          CALL ABORT('STOP in Fromcpl')
+      ENDIF
+      CLOSE(nuread)
+      WRITE(nuout,*) "Succesful for reading "//fldnom
+      CALL flush (nuout)
+c
+c sea-ice cover:
+c
+      pipnom = "Siicecov"
+      fldnom = "SIICECOV"
+      filnom = "atmice"
+      WRITE (nuout,*) "Waiting for the pipe "//pipnom
+      CALL flush (nuout)
+#ifdef CRAY
+      READ (pipnom) icpliter
+#else
+      iret = 0
+      isize = 1
+      CALL pipread(pipnom, icpliter, isize, iret)
+#endif
+      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      nuread = 99
+      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(nuout,*) "Error while connecting "//filnom, nuread
+          CALL flush (nuout)
+          CALL ABORT("STOP in Fromcpl")
+      ENDIF
+      REWIND (UNIT = nuread)
+      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      CALL locread(fldnom, sic, imjm, nuread, iflag)
+      IF (iflag .NE. 0) THEN
+          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
+          WRITE(nuout,*) "jour, iflag = ", jour, iflag
+          CALL flush (nuout)
+          CALL ABORT('STOP in Fromcpl')
+      ENDIF
+      CLOSE(nuread)
+      WRITE(nuout,*) "Succesful for reading "//fldnom
+      CALL flush (nuout)
+c
+c sea-ice albedo:
+c
+      pipnom = "Siicealb"
+      fldnom = "SIICEALB"
+      filnom = "atmice"
+      WRITE (nuout,*) "Waiting for the pipe "//pipnom
+      CALL flush (nuout)
+#ifdef CRAY
+      READ (pipnom) icpliter
+#else
+      iret = 0
+      isize = 1
+      CALL pipread(pipnom, icpliter, isize, iret)
+#endif
+      WRITE (nuout,*) "Ready to read "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      nuread = 99
+      OPEN(nuread, FILE=filnom, FORM='unformatted', IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(nuout,*) "Error while connecting "//filnom, nuread
+          CALL flush (nuout)
+          CALL ABORT("STOP in Fromcpl")
+      ENDIF
+      REWIND (UNIT = nuread)
+      WRITE(nuout,*) "Reading "//fldnom//" from "//filnom
+      CALL flush (nuout)
+      CALL locread(fldnom, alb_sic, imjm, nuread, iflag)
+      IF (iflag .NE. 0) THEN
+          WRITE(nuout,*) "Pb in reading "//fldnom//" from "//filnom
+          WRITE(nuout,*) "jour, iflag = ", jour, iflag
+          CALL flush (nuout)
+          CALL ABORT('STOP in Fromcpl')
+      ENDIF
+      CLOSE(nuread)
+      WRITE(nuout,*) "Succesful for reading "//fldnom
+      CALL flush (nuout)
+c
+      ELSE ! cchain.EQ."CLIM"
+c
+      jktm1=jour-1
+c
+      CALL CLIM_Import ('SISUTESU', jktm1, sst, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE(nuout,*)'Pb in reading ', 'SISUTESU'
+         WRITE(nuout,*)'Atmosphere jour is = ',jour
+         WRITE(nuout,*)'Couplage kt is = ',jktm1
+         WRITE(nuout,*)'CLIM error code is = ', info
+         WRITE(nuout,*)'STOP in Fromcpl'
+         CALL abort
+      ENDIF
+c
+      CALL CLIM_Import ('SIALBEDO', jktm1, alb_sst, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE(nuout,*)'Pb in reading ', 'SIALBEDO'
+         WRITE(nuout,*)'Atmosphere jour is = ',jour
+         WRITE(nuout,*)'Couplage kt is = ',jktm1
+         WRITE(nuout,*)'CLIM error code is = ', info
+         WRITE(nuout,*)'STOP in Fromcpl'
+         CALL abort
+      ENDIF
+c
+      CALL CLIM_Import ('SIICECOV', jktm1, sic, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE(nuout,*)'Pb in reading ', 'SIICECOV'
+         WRITE(nuout,*)'Atmosphere jour is = ',jour
+         WRITE(nuout,*)'Couplage kt is = ',jktm1
+         WRITE(nuout,*)'CLIM error code is = ', info
+         WRITE(nuout,*)'STOP in Fromcpl'
+         CALL abort
+      ENDIF
+c
+      CALL CLIM_Import ('SIICEALB', jktm1, alb_sic, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE(nuout,*)'Pb in reading ', 'SIICEALB'
+         WRITE(nuout,*)'Atmosphere jour is = ',jour
+         WRITE(nuout,*)'Couplage kt is = ',jktm1
+         WRITE(nuout,*)'CLIM error code is = ', info
+         WRITE(nuout,*)'STOP in Fromcpl'
+         CALL abort
+      ENDIF
+c
+      ENDIF ! fin de test sur cchain
+c
+      RETURN
+      END
+
+      SUBROUTINE locread (cdfldn, pfield, kdimax, knulre, kflgre)
+      IMPLICIT none
+      INTEGER kdimax, knulre, kflgre
+C****
+C               *****************************
+C               * OASIS ROUTINE  -  LEVEL 0 *
+C               * -------------     ------- *
+C               *****************************
+C
+C**** *locread*  - Read binary field on unit knulre
+C
+C     Purpose:
+C     -------
+C     Find string cdfldn on unit knulre and read array pfield
+C
+C**   Interface:
+C     ---------
+C       *CALL*  *locread (cdfldn, pfield, kdimax, knulre, kflgre)*
+C
+C     Input:
+C     -----
+C                cdfldn : character string locator
+C                kdimax : dimension of field to be read 
+C                knulre : logical unit to be read 
+C
+C     Output:
+C     ------
+C                pfield : field array (real 1D)
+C                kflgre : error status flag
+C
+C     Workspace:
+C     ---------
+C     None
+C
+C     Externals:
+C     ---------
+C     None
+C
+C     Reference:
+C     ---------
+C     See OASIS manual (1995) 
+C
+C     History:
+C     -------
+C       Version   Programmer     Date      Description
+C       -------   ----------     ----      -----------  
+C       2.0       L. Terray      95/09/01  created
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C* ---------------------------- Include files ---------------------------
+C
+C
+C* ---------------------------- Argument declarations -------------------
+C
+      REAL pfield(kdimax)
+      CHARACTER*8 cdfldn
+C
+C* ---------------------------- Local declarations ----------------------
+C
+      CHARACTER*8 clecfl
+      INTEGER nulou
+c
+      nulou = 6
+C
+C* ---------------------------- Poema verses ----------------------------
+C
+C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+C
+C*    1. Initialization
+C        --------------
+C
+c     WRITE (UNIT = nulou,FMT = *) ' '
+c     WRITE (UNIT = nulou,FMT = *) ' '
+c     WRITE (UNIT = nulou,FMT = *) 
+c    $    '           ROUTINE locread  -  Level 0'
+c     WRITE (UNIT = nulou,FMT = *) 
+c    $    '           ***************     *******'
+c     WRITE (UNIT = nulou,FMT = *) ' '
+c     WRITE (UNIT = nulou,FMT = 1001) knulre
+c     WRITE (UNIT = nulou,FMT = *) ' '
+C
+C* Formats
+C
+ 1001 FORMAT(5X,' Read binary file connected to unit = ',I3)
+C
+C     2. Find field in file
+C        ------------------
+C
+      REWIND knulre
+ 200  CONTINUE
+C* Find string
+      READ (UNIT = knulre, ERR = 210, END = 210) clecfl
+      IF (clecfl .NE. cdfldn) GO TO  200
+C* Read associated field
+      READ (UNIT = knulre, ERR = 210, END = 210) pfield
+C* Reading done and ok
+      kflgre = 0
+      GO TO 220
+C* Problem in reading
+ 210  kflgre = 1
+ 220  CONTINUE
+C
+C
+C*    3. End of routine
+C        --------------
+C
+c     WRITE (UNIT = nulou,FMT = *) 
+c    $    '          --------- End of routine locread ---------'
+c     WRITE (UNIT = nulou,FMT = *) ' '
+c     CALL FLUSH (nulou)
+      RETURN
+      END
+
+
+      SUBROUTINE intocpl(itau,imjm,
+     .                   fsol, fnsol,
+     .                   rain, snow, evap, ruisoce, ruisriv,
+     .                   tsol, fder, albe,
+     .                   taux, tauy)
+      IMPLICIT NONE
+c
+c Laurent Z.X Li (Feb. 10, 1997): It provides several fields to the
+c coupler. Of course, it sends a message to the corresponding pipes
+c after the writting.
+c
+      INTEGER itau, imjm
+c
+      REAL fsol(imjm)
+      REAL fnsol(imjm)
+      REAL rain(imjm)
+      REAL snow(imjm)
+      REAL evap(imjm)
+      REAL ruisoce(imjm)
+      REAL ruisriv(imjm)
+      REAL tsol(imjm)
+      REAL fder(imjm)
+      REAL albe(imjm)
+      REAL taux(imjm)
+      REAL tauy(imjm)
+c
+      INTEGER nuout
+      PARAMETER (nuout = 6)
+C
+      INTEGER nuwrit, ios
+      CHARACTER*8 pipnom
+      CHARACTER*8 fldnom
+      CHARACTER*8 filnom
+c
+c
+#include "oasis.h"
+#include "clim.h"
+      INTEGER info
+      INTEGER isize, iret
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Intocpl: send fields to CPL, itau= ", itau
+      WRITE(nuout,*) " "
+c
+      IF (cchain.EQ."PIPE") THEN
+c
+      nuwrit = 99
+      filnom = "atmflx"
+      OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(6,*) "Error while connecting "//filnom
+          CALL ABORT('STOP in intocpl')
+      ENDIF
+      REWIND ( UNIT = nuwrit)
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Writting fields to "//filnom, nuwrit
+      WRITE(nuout,*) " "
+      CALL flush(nuout)
+C
+C            ecriture CONSFTOT (flux non solaire)
+C
+      fldnom = "CONSFTOT"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) fnsol
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COSHFTOT (solaire)
+C
+      fldnom = "COSHFTOT"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) fsol
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COTOLPSU (precipitation liquide)
+C
+      fldnom = "COTOLPSU"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) rain
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COTOSPSU (precipitation solide)
+C
+      fldnom = "COTOSPSU"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) snow
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COTFSHSU (evaporation)
+C
+      fldnom = "COTFSHSU"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) evap
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COSSTSST (temperature du sol)
+C
+      fldnom = "COSSTSST"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) tsol
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture CODFLXDT (derivee du flux non-solaire)
+C
+      fldnom = "CODFLXDT"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) fder
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture COALBSUR (albedo moyen)
+C
+      fldnom = "COALBSUR"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) albe
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture CORUNCOA (runoff DIRECT)
+C
+      fldnom = "CORUNCOA"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) ruisoce
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C           ecriture river runoff 'CORIVFLU'
+C
+      fldnom = "CORIVFLU"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) ruisriv
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+c
+      CLOSE(UNIT = nuwrit)
+C
+C simulate a FLUSH
+C
+      OPEN(nuwrit, FILE=filnom, FORM='unformatted')
+      CLOSE(UNIT = nuwrit)
+C
+C Send message to pipes:
+c
+      pipnom = 'Consftot'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Coshftot'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cotolpsu'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cotospsu'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cotfshsu'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cosstsst'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Codflxdt'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Coalbsur'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Coruncoa'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Corivflu'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+C
+C Send wind stresses to coupler
+c
+      nuwrit = 99
+      filnom = "atmtau"
+      OPEN(nuwrit, FILE=filnom, FORM="unformatted", IOSTAT=ios)
+      IF (ios .NE. 0) THEN
+          WRITE(6,*) "Error while connecting "//filnom
+          CALL ABORT('STOP in intocpl')
+      ENDIF
+      REWIND ( UNIT = nuwrit)
+c
+      WRITE(nuout,*) " "
+      WRITE(nuout,*) "Writting fields to "//filnom, nuwrit
+      WRITE(nuout,*) " "
+C
+C ecriture COZOTAUX
+c
+      fldnom = "COZOTAUX"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) taux
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+c
+      fldnom = "COZOTAU2"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) taux
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+C
+C ecriture COMETAUY
+C
+      fldnom = "COMETAUY"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) tauy
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+c
+      fldnom = "COMETAU2"
+      WRITE(UNIT = nuwrit) fldnom, 'LMD7246T00000000OAS DA  '
+      WRITE(UNIT = nuwrit) tauy
+      WRITE(nuout,*) fldnom//" recorded to "//filnom, nuwrit
+c
+      CLOSE(UNIT = nuwrit)
+C
+C simulate a FLUSH
+C
+      OPEN(nuwrit, FILE=filnom, FORM='unformatted')
+      CLOSE(UNIT = nuwrit)
+c
+c Send message to pipes:
+c
+      pipnom = 'Cozotaux'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cozotau2'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cometauy'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      pipnom = 'Cometau2'
+#ifdef CRAY
+      WRITE(pipnom) itau
+#else
+      isize=1
+      iret=0
+      CALL pipwrite(pipnom,itau,isize,iret)
+#endif
+      WRITE(nuout,*) "Message sent to pipe "//pipnom
+c
+      ELSE ! cchain.EQ."CLIM"
+c
+      CALL CLIM_Export("CONSFTOT", itau, fnsol, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export fnsol pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COSHFTOT", itau, fsol, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export fsol pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COTOLPSU", itau, rain, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export rain pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COTOSPSU", itau, snow, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export snow pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COTFSHSU", itau, evap, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export evap pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COSSTSST", itau, tsol, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export tsol pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("CODFLXDT", itau, fder, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COALBSUR", itau, albe, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export fder pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("CORUNCOA", itau, ruisoce, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export ruisoce pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("CORIVFLU", itau, ruisriv, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export ruisriv pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COZOTAUX", itau, taux, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COZOTAU2", itau, taux, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export taux pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COMETAUY", itau, tauy, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      CALL CLIM_Export("COMETAU2", itau, tauy, info)
+      IF (info .NE. CLIM_Ok) THEN
+         WRITE (nuout,*) "intocpl: CLIM_Export tauy pb. ", info
+         CALL ABORT("STOP in intocpl")
+      ENDIF
+c
+      ENDIF
+c
+      RETURN
+      END
+      SUBROUTINE quitcpl
+      IMPLICIT none
+c
+c Sortir du coupleur
+c
+      INTEGER nuout   ! listing output unit
+      PARAMETER (nuout=6)
+c
+#include "oasis.h"
+#include "clim.h"
+      INTEGER info
+c
+      IF (cchain.EQ."PIPE") THEN
+c
+         WRITE(nuout,*)"On sort du coupleur sans rien faire"
+c
+      ELSE ! cchain.EQ."CLIM"
+c
+         CALL CLIM_Quit(CLIM_StopPvm,info)
+         IF (info.NE.CLIM_Ok) THEN
+            WRITE(nuout,*)"Erreur pour quiter coupleur:",info
+         ENDIF
+c
+      ENDIF
+c
+      RETURN
+      END
+
+
+      SUBROUTINE makepipe
+      PRINT*, "rien"
+      END
+      SUBROUTINE pipwrite
+      PRINT*, "rien"
+      END
+      SUBROUTINE pipread
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Init
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Define
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Start
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Stepi
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Import
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_Export
+      PRINT*, "rien"
+      END
+      SUBROUTINE CLIM_quit
+      PRINT*, "rien"
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/oasis.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/oasis.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/oasis.h	(revision 3)
@@ -0,0 +1,6 @@
+      LOGICAL ok_oasis
+      PARAMETER (ok_oasis = .FALSE.)
+c
+      CHARACTER*8 cchain
+      PARAMETER (cchain="PIPE")
+c      PARAMETER (cchain="CLIM")
Index: LMDZ.3.3/branches/LF/libf/phylmd/orbite.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/orbite.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/orbite.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/orografi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/orografi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/orografi.F	(revision 3)
@@ -0,0 +1,1750 @@
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kgwdim,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, kgwdim, 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,kgwdim,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, kgwdim, 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 )
+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
+      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
+      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),
+     *       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),
+     *       ztfr(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+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, nlev , ktest 
+     *     , ikcrit, ikcrith, icrit, isect, ikhlim, 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
+     *    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval
+     *    , ztfr   , ztau 
+     *    , pgeom1,pgamma,zd1,zd2,zdmod,znu)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx  , ktest
+     *       , ikcrit, ikcrith, icrit  , ikenvh, iknu
+     *       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph
+     *       , zri   , ztau   , ztauf
+c
+     *       , zdmod , znu    , psig  , pgamma , pstd , ppic , pval)
+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   , nlev  , ktest
+     *         , kkcrit, kkcrith, kcrit, ksect , kkhlim
+     *         , 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 logical (l)
+c
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(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
+      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),zpsi(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
+     *         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic , pval  , ptfr  , ptau  
+     *         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+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 logical (l)
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),ptfr(nlon),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
+      real pmea(nlon),ppic(nlon),pval(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+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  , ktest
+     *         , KKCRIT, KKCRITH, KCRIT ,  kkenvh, kknu,kknu2
+     *         , PAPHM1, PRHO   , PSTAB , PTFR , PVPH , PRI , PTAU
+     *         , ptauf ,pdmod   , pnu   , psig ,pgamma, pvar, ppic,pval)
+
+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 LOGICAL (L)
+C
+
+C
+
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KKCRIT(NLON),KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon),ktest(NLON)
+     *       ,kkenvh(NLON),kknu(NLON),kknu2(NLON)
+C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
+     *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
+     *     PRI   (NLON,NLEV+1), PTFR (NLON), PTAU(NLON,NLEV+1),
+     *     ptauf (NLON,nlev+1)
+     
+      REAL pdmod (NLON) , pnu (NLON) , psig(NLON),
+     *     pgamma(NLON) , pvar(NLON) , ppic(NLON), pval(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+      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, psig, pgam, pthe, ppic,pval,
+     e                   kgwd,kgwdim,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 plat(nlon),pmea(nlon)
+      REAL 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, kgwdim, 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 OROLIFT(klon,klev,kgwd,kgwdim,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            plat,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 OROLIFT( NLON,NLEV
+     I                 , KGWD, KGWDIM, KDX, KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PAPM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, PSIG, PGAMMA, PTHETA,ppic,pval
+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 LOGICAL (L)
+C
+C
+#include "dimensions.h"
+#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      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),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),
+     *         IKNUB(klon),
+     *         IKNUL(klon),
+     *         IKCRIT(KLON),
+     *         IKHLIM(KLON)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZSTAB(KLON,KLEV+1),
+     *       ZVPH(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1),
+     *       ZRI(KLON,KLEV+1),
+     *       ZpsI(KLON,KLEV+1),
+     *       Zzdep(KLON,KLEV)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON),
+     *       ZDTDT(KLON),
+     *       ZDEDT(KLON),
+     *       ZVIDIS(KLON),
+     *       ZTFR(KLON),
+     *       Znu(KLON),
+     *       Zd1(KLON),
+     *       Zd2(KLON),
+     *       Zdmod(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 LOGICAL(L)
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      integer nlon,nlev
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+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/branches/LF/libf/phylmd/ozonecm.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/ozonecm.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/ozonecm.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/phyetat0.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phyetat0.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/phyetat0.F	(revision 3)
@@ -0,0 +1,681 @@
+      SUBROUTINE phyetat0 (fichnom,dtime,co2_ppm,solaire,
+     .            rlat,rlon,tsol,tsoil,deltat,qsol,snow,
+     .           radsol,rugmer,agesno,clesphy0,
+     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel,tabcntr0)
+      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"
+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 radsol(klon)
+      REAL rugmer(klon)
+      REAL agesno(klon)
+      REAL zmea(klon)
+      REAL zstd(klon)
+      REAL zsig(klon)
+      REAL zgam(klon)
+      REAL zthe(klon)
+      REAL zpic(klon)
+      REAL zval(klon)
+      REAL rugsrel(klon)
+
+      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
+      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
+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 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 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 en mer:
+c
+      ierr = NF_INQ_VARID (nid, "RUGMER", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <RUGMER> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rugmer)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rugmer)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <RUGMER>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rugmer(i),xmin)
+         xmax = MAX(rugmer(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite sur la mer rugmer:', xmin, xmax
+c
+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*, "          Valeur par default: 50"
+         DO i = 1, klon
+            agesno(i) = 50.0
+         ENDDO
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, agesno)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, agesno)
+#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),xmin)
+            xmax = MAX(agesno(i),xmax)
+         ENDDO
+         PRINT*,'Age de la neige agesno:', xmin, xmax
+      ENDIF
+c
+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 Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/phyredem.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phyredem.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/phyredem.F	(revision 3)
@@ -0,0 +1,393 @@
+      SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire,
+     .           rlat,rlon,tsol,tsoil,deltat,qsol,snow,
+     .           radsol,rugmer,agesno,
+     .           zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel)
+      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"
+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 radsol(klon)
+      REAL rugmer(klon)
+      REAL agesno(klon)
+      REAL zmea(klon)
+      REAL zstd(klon)
+      REAL zsig(klon)
+      REAL zgam(klon)
+      REAL zthe(klon)
+      REAL zpic(klon)
+      REAL zval(klon)
+      REAL rugsrel(klon)
+c
+      INTEGER nid, nvarid, idim1, idim2
+      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)
+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) = dayref
+      tab_cntrl(14) = anneeref
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid)
+#else
+      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
+      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,"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, "RUGMER", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28,
+     .                        "Longueur de rugosite sur mer")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "AGESNO", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "AGESNO", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15,
+     .                        "Age de la neige")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,zval)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel)
+#endif
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/physiq.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/physiq.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/physiq.F	(revision 3)
@@ -0,0 +1,2498 @@
+      SUBROUTINE physiq (nlon,nlev,nqmax  ,
+     .            debut,lafin,rjourvrai,rjour_ecri,gmtime,pdtphys,
+     .            paprs,pplay,pphi,pphis,paire,presnivs,clesphy0,
+     .            u,v,t,qx,
+     .            d_u_dyn, d_v_dyn,  d_t_dyn, d_qx_dyn,
+     .            omega,
+     .            d_u, d_v, d_t, d_qx, d_ps)
+      USE ioipsl
+      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_u_dyn-input-R-tendance dynamique pour "u" (m/s/s)
+c d_v_dyn-input-R-tendance dynamique pour "v" (m/s/s)
+c d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
+c d_qx_dyn-input-R-tendance dynamique pour "qx" (kg/kg/s)
+c omega---input-R-vitesse verticale en Pa/s
+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"
+#include "dimphy.h"
+#include "regdim.h"
+#include "indicesol.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "control.h"
+c======================================================================
+      LOGICAL check ! Verifier la conservation du modele en eau
+      PARAMETER (check=.FALSE.)
+c======================================================================
+c Parametres lies au coupleur OASIS:
+#include "oasis.h"
+      INTEGER npas, nexca, itimestep
+      logical rnpb
+      parameter(rnpb=.true.)
+      PARAMETER (npas=1440)
+      PARAMETER (nexca=48)
+      PARAMETER (itimestep=1800)
+      EXTERNAL intocpl, inicma
+c======================================================================
+c ok_ocean indique l'utilisation du modele oceanique "slab ocean",
+c il faut bien sur s'assurer que le bilan energetique de reference
+c a la surface de l'ocean est bien present dans le fichier des
+c conditions aux limites, ainsi que l'indicateur du sol ne contient
+c pas de glace oceanique (pas de valeur 3).
+c
+      LOGICAL ok_ocean
+      PARAMETER (ok_ocean=.FALSE.)
+      REAL cyang  ! capacite thermique de l'ocean superficiel
+      PARAMETER (cyang=30.0 * 4.228e+06)
+      REAL cbing  ! capacite thermique de la glace oceanique
+      PARAMETER (cbing=1.0 * 4.228e+06)
+      REAL cthermiq
+c======================================================================
+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.)
+      REAL soilcap(klon,nbsrf), soilflux(klon,nbsrf)
+      SAVE soilcap, soilflux
+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
+      PARAMETER (ok_journe=.FALSE.)
+c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      PARAMETER (ok_mensuel=.TRUE.)
+c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      PARAMETER (ok_instan=.FALSE.)
+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)
+c
+      INTEGER nvm           ! nombre de vegetations
+      PARAMETER (nvm=8)
+      REAL veget(klon,nvm)  ! couverture vegetale
+      SAVE veget
+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 u(klon,klev)
+      REAL v(klon,klev)
+      REAL t(klon,klev)
+      REAL qx(klon,klev,nqmax)
+
+      REAL d_u_dyn(klon,klev)
+      REAL d_v_dyn(klon,klev)
+      REAL d_t_dyn(klon,klev)
+      REAL d_qx_dyn(klon,klev,2)
+
+      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)
+
+      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 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 rugmer(klon)
+      SAVE rugmer                 ! longeur de rugosite sur mer (m)
+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,igwdim,idx(klon),itest(klon)
+c
+      REAL agesno(klon)
+      SAVE agesno                 ! age de la neige
+c
+      REAL alb_neig(klon)
+      SAVE alb_neig               ! albedo de la neige
+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=.TRUE.)
+      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
+      REAL evap(klon), devap(klon) ! evaporation et sa derivee
+      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+      REAL bils(klon) ! bilan de chaleur au sol
+      REAL fder(klon) ! Derive de flux (sensible et latente) 
+      REAL ruis(klon) ! ruissellement
+      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
+      REAL zxrugs(klon) ! longueur de rugosite
+c
+c Conditions aux limites
+c
+      INTEGER julien
+      INTEGER idayvrai
+      SAVE idayvrai
+c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+      REAL pctsrf(klon,nbsrf)
+      SAVE pctsrf                 ! sous-fraction du sol
+      REAL lmt_sst(klon)
+      SAVE lmt_sst                ! temperature de la surface ocean
+      REAL lmt_bils(klon)
+      SAVE lmt_bils               ! bilan de chaleur au sol
+      REAL lmt_alb(klon)
+      SAVE lmt_alb                ! temperature de la surface ocean
+      REAL lmt_rug(klon)
+      SAVE lmt_rug                ! longueur de rugosite
+      REAL alb_eau(klon)
+      SAVE alb_eau                ! albedo sur l'ocean
+      REAL albsol(klon)
+      SAVE albsol                 ! albedo du sol total
+      REAL 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)
+      EXTERNAL diagcld   ! nuages diagnostiques
+      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 hydrol    ! hydrologie du sol
+      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 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
+      REAL fluxq(klon,klev)   ! flux turbulent d'humidite
+      REAL fluxt(klon,klev)   ! flux turbulent de chaleur
+      REAL fluxu(klon,klev)   ! flux turbulent de vitesse u
+      REAL fluxv(klon,klev)   ! flux turbulent de vitesse v
+c
+      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 topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
+      REAL albpla(klon)
+c Le rayonnement n'est pas calcule tous les pas, il faut donc
+c                      sauvegarder les sorties du rayonnement
+      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw
+      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+      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 zx_alb_lic, zx_alb_oce, zx_alb_ter, zx_alb_sic
+      REAL zxtsol(klon), zxqsol(klon), zxsnow(klon)
+c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+c
+      CHARACTER*2 str2
+      CHARACTER*2 iqn
+c
+      REAL za, zb
+      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
+      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_y(jjm+1)
+      REAL zx_relief(iim,jjm+1)
+      REAL zx_aire(iim,jjm+1)
+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)
+c      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)
+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)
+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
+      REAL oas_sols(klon), z_sols(iim,jjm+1)
+      SAVE oas_sols
+      REAL oas_nsol(klon), z_nsol(iim,jjm+1)
+      SAVE oas_nsol
+      REAL oas_rain(klon), z_rain(iim,jjm+1)
+      SAVE oas_rain
+      REAL oas_snow(klon), z_snow(iim,jjm+1)
+      SAVE oas_snow
+      REAL oas_evap(klon), z_evap(iim,jjm+1)
+      SAVE oas_evap
+      REAL oas_ruis(klon), z_ruis(iim,jjm+1)
+      SAVE oas_ruis
+      REAL oas_tsol(klon), z_tsol(iim,jjm+1)
+      SAVE oas_tsol
+      REAL oas_fder(klon), z_fder(iim,jjm+1)
+      SAVE oas_fder
+      REAL oas_albe(klon), z_albe(iim,jjm+1)
+      SAVE oas_albe
+      REAL oas_taux(klon), z_taux(iim,jjm+1)
+      SAVE oas_taux
+      REAL oas_tauy(klon), z_tauy(iim,jjm+1)
+      SAVE oas_tauy
+      REAL oas_ruisoce(klon), z_ruisoce(iim,jjm+1)
+      SAVE oas_ruisoce
+      REAL oas_ruisriv(klon), z_ruisriv(iim,jjm+1)
+      SAVE oas_ruisriv
+c
+c
+c Variables locales pour effectuer les appels en serie
+c
+      REAL t_seri(klon,klev), q_seri(klon,klev)
+      REAL ql_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 source_tr(klon,nbtr)
+
+      REAL zx_rh(klon,klev)
+      REAL dtimeday,dtimecri,dtimexp9,fecri_pas,fecri86400,fecritday
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+c
+      INTEGER ndex(1)
+      REAL zx_tmp_fi2d(klon)
+      REAL zx_tmp_2d(iim,jjm+1), zx_tmp_3d(iim,jjm+1,klev)
+      REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+c
+      INTEGER nid_day, nid_mth, nid_ins
+      SAVE nid_day, nid_mth, nid_ins
+c
+      INTEGER nhori, nvert
+      REAL zsto, zout, zjulian
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+
+c
+c Declaration des constantes et des fonctions thermodynamiques
+c
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c======================================================================
+      modname = 'physiq'
+      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 (ok_oasis) THEN
+            PRINT*, "Attentions! les parametres suivants sont fixes:"
+            PRINT *,'***********************************************'
+            PRINT*, "npas, nexca, itimestep=", npas, nexca, itimestep
+            PRINT*, "Changer-les manuellement s il le faut"
+            PRINT *,'***********************************************'
+            CALL inicma( npas, nexca, itimestep)
+         ENDIF
+c
+         IF (ok_ocean) THEN
+            PRINT*, '************************'
+            PRINT*, 'SLAB OCEAN est active, prenez precautions !'
+            PRINT*, '************************'
+         ENDIF
+c
+         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 Initialiser les compteurs:
+c
+
+         itap    = 0
+         itaprad = 0
+c
+         CALL phyetat0 ("startphy.nc",dtime,co2_ppm,solaire,
+     .         rlat,rlon,ftsol,ftsoil,deltat,fqsol,fsnow,
+     .        radsol,rugmer,agesno,clesphy0,
+     .       zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro,tabcntr0 )
+
+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
+c
+         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
+         IF (soil_model) THEN
+            DO nsrf = 1, nbsrf
+            CALL soil(dtime, nsrf, fsnow(1,nsrf),
+     .                ftsol(1,nsrf), ftsoil(1,1,nsrf),
+     .                soilcap(1,nsrf), soilflux(1,nsrf))
+            ENDDO
+         ENDIF
+c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         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
+         ecrit_ins = NINT(86400./dtime *0.25)  ! tous les jours
+         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
+      IF (ok_journe) THEN
+c
+C         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
+         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + dayref
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjm+1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+         CALL histbeg("histday", iim,zx_lon, jjm+1,zx_lat,
+     .                 1,iim,1,jjm+1, 0, zjulian, dtime, 
+     .                 nhori, nid_day)
+c         CALL histvert(nid_day, "presnivs", "Vertical levels", "mb",
+c     .                 klev, presnivs, nvert)
+         call histvert(nid_day, 'sig_s', 'Niveaux sigma','-',
+     .              klev, znivsig, nvert)
+c
+         zsto = dtime
+         zout = dtime * FLOAT(ecrit_day)
+c
+         CALL histdef(nid_day, "phis", "Surface geop. height", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_day, "aire", "Grid area", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_day, "tsol", "Surface Temperature", "K",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "psol", "Surface Pressure", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "rain", "Precipitation", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "snow", "Snow fall", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "evap", "Evaporation", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "frtu", "Zonal wind stress", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "frtv", "Meridional wind stress", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "ruis", "Runoff", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "sicf", "Sea-ice fraction", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldl", "Low-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldh", "High-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldt", "Total cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "cldq", "Cloud liquid water path", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_day, "temp", "Air temperature", "K",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "ovap", "Specific humidity", "Kg/Kg",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "geop", "Geopotential height", "m",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitu", "Zonal wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitv", "Meridional wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "vitw", "Vertical wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_day, "pres", "Air pressure", "Pa",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histend(nid_day)
+c
+         ndex(1) = 0
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_day,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+         CALL histwrite(nid_day,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      ENDIF ! fin de test sur ok_journe
+c
+      IF (ok_mensuel) THEN
+c
+c         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
+         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + dayref
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjm+1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+         CALL histbeg("histmth", iim,zx_lon, jjm+1,zx_lat,
+     .                 1,iim,1,jjm+1, 0, zjulian, dtime, 
+     .                 nhori, nid_mth)
+c         CALL histvert(nid_mth, "presnivs", "Vertical levels", "mb",
+c     .                 klev, presnivs, nvert)
+         call histvert(nid_mth, 'sig_s', 'Niveaux sigma','-',
+     .              klev, znivsig, nvert)
+c
+         zsto = dtime
+         zout = dtime * ecrit_mth
+c
+         CALL histdef(nid_mth, "phis", "Surface geop. height", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "once",  zsto,zout)
+c
+         CALL histdef(nid_mth, "aire", "Grid area", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "once",  zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_mth, "tsol", "Surface Temperature", "K",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "psol", "Surface Pressure", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "qsol", "Surface humidity", "mm",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "rain", "Precipitation", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "plul", "Large-scale Precip.", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "pluc", "Convective Precip.", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "snow", "Snow fall", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ages", "Snow age", "day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "evap", "Evaporation", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "tops", "Solar rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "topl", "IR rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "sols", "Solar rad. at surf.", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "soll", "IR rad. at surface", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "tops0", "Solar rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "topl0", "IR rad. at TOA", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "sols0", "Solar rad. at surf.", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "soll0", "IR rad. at surface", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "bils", "Surf. total heat flux", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "sens", "Sensible heat flux", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "fder", "Heat flux derivation", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "frtu", "Zonal wind stress", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "frtv", "Meridional wind stress", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ruis", "Runoff", "mm/day",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "sicf", "Sea-ice fraction", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "albs", "Surface albedo", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cdrm", "Momentum drag coef.", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cdrh", "Heat drag coef.", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldl", "Low-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldm", "Mid-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldh", "High-level cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldt", "Total cloudiness", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "cldq", "Cloud liquid water path", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ue", "Zonal energy transport", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ve", "Merid energy transport", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "uq", "Zonal humidity transport", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vq", "Merid humidity transport", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32, 
+     .                "ave(X)", zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_mth, "temp", "Air temperature", "K",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "ovap", "Specific humidity", "Kg/Kg",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "geop", "Geopotential height", "m",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitu", "Zonal wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitv", "Meridional wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "vitw", "Vertical wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "pres", "Air pressure", "Pa",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "rneb", "Cloud fraction", "-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "rhum", "Relative humidity", "-",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "oliq", "Liquid water content", "kg/kg",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtdyn", "Dynamics dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqdyn", "Dynamics dQ", "Kg/Kg/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtcon", "Convection dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqcon", "Convection dQ", "Kg/Kg/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlsc", "Condensation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqlsc", "Condensation dQ", "Kg/Kg/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtvdf", "Boundary-layer dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqvdf", "Boundary-layer dQ", "Kg/Kg/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dteva", "Reevaporation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dqeva", "Reevaporation dQ", "Kg/Kg/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+c         CALL histdef(nid_mth, "dtajs", "Dry adjust. dT", "K/s",
+c     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+c     .                "ave(X)", zsto,zout)
+c
+c         CALL histdef(nid_mth, "dqajs", "Dry adjust. dQ", "Kg/Kg/s",
+c     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+c     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtswr", "SW radiation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtsw0", "SW radiation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlwr", "LW radiation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dtlw0", "LW radiation dT", "K/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "duvdf", "Boundary-layer dU", "m/s2",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvvdf", "Boundary-layer dV", "m/s2",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         IF (ok_orodr) THEN
+         CALL histdef(nid_mth, "duoro", "Orography dU", "m/s2",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvoro", "Orography dV", "m/s2",
+     .                iim,jjm+1,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,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+c
+         CALL histdef(nid_mth, "dvlif", "Orography dV", "m/s2",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         ENDIF
+C
+         CALL histdef(nid_mth, "ozone", "Ozone concentration", "-",
+     .                iim,jjm+1,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,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "ave(X)", zsto,zout)
+         ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+         ENDIF
+         ENDDO
+         ENDIF
+c
+         CALL histend(nid_mth)
+c
+         ndex(1) = 0
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_mth,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
+C
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+         CALL histwrite(nid_mth,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      ENDIF ! fin de test sur ok_mensuel
+c
+c
+      IF (ok_instan) THEN
+c
+c         CALL ymds2ju(1900, 1, 1, 0.0, zjulian)
+         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + dayref
+c
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjm+1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+         CALL histbeg("histins", iim,zx_lon, jjm+1,zx_lat,
+     .                 1,iim,1,jjm+1, 0, zjulian, dtime,
+     .                 nhori, nid_ins)
+c         CALL histvert(nid_ins, "presnivs", "Vertical levels", "mb",
+c     .                 klev, presnivs, nvert)
+         call histvert(nid_ins, 'sig_s', 'Niveaux sigma','-',
+     .              klev, znivsig, nvert)
+c
+         zsto = dtime * ecrit_ins
+         zout = dtime * ecrit_ins
+C
+         CALL histdef(nid_ins, "phis", "Surface geop. height", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+         CALL histdef(nid_ins, "aire", "Grid area", "-",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "once", zsto,zout)
+c
+c Champs 2D:
+c
+         CALL histdef(nid_ins, "psol", "Surface Pressure", "Pa",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "topl", "OLR", "W/m2",
+     .                iim,jjm+1,nhori, 1,1,1, -99, 32,
+     .                "inst(X)", zsto,zout)
+c
+c Champs 3D:
+c
+         CALL histdef(nid_ins, "temp", "Temperature", "K",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitu", "Zonal wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "vitv", "Merid wind", "m/s",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "geop", "Geopotential height", "m",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histdef(nid_ins, "pres", "Air pressure", "Pa",
+     .                iim,jjm+1,nhori, klev,1,klev,nvert, 32,
+     .                "inst(X)", zsto,zout)
+c
+         CALL histend(nid_ins)
+c
+         ndex(1) = 0
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,pphis,zx_tmp_2d)
+         CALL histwrite(nid_ins,"phis",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+         i = NINT(zout/zsto)
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,paire,zx_tmp_2d)
+         CALL histwrite(nid_ins,"aire",i,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      ENDIF
+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
+         IF (ok_oasis) THEN
+         DO i = 1, klon
+           oas_sols(i) = 0.0
+           oas_nsol(i) = 0.0
+           oas_rain(i) = 0.0
+           oas_snow(i) = 0.0
+           oas_evap(i) = 0.0
+           oas_ruis(i) = 0.0
+           oas_tsol(i) = 0.0
+           oas_fder(i) = 0.0
+           oas_albe(i) = 0.0
+           oas_taux(i) = 0.0
+           oas_tauy(i) = 0.0
+         ENDDO
+         ENDIF
+c
+      ENDIF
+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)
+      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
+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
+         idayvrai = NINT(xjour)
+         PRINT *,' PHYS cond  julien ',julien,idayvrai
+         CALL condsurf(julien,idayvrai, pctsrf ,
+     .                  lmt_sst,lmt_alb,lmt_rug,lmt_bils  )
+         CALL ozonecm( FLOAT(julien), rlat, paprs, wo)
+      ENDIF
+c
+ 
+      IF (ok_ocean) THEN
+         DO i = 1, klon
+            ftsol(i,is_oce) = lmt_sst(i) + deltat(i)
+         ENDDO
+
+      ELSE
+         DO i = 1, klon
+            ftsol(i,is_oce) = lmt_sst(i)
+         ENDDO
+
+      ENDIF
+c
+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))
+         zlsdcp=RLSTT/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
+c Appeler la diffusion verticale (programme de couche limite)
+c
+      DO i = 1, klon
+         frugs(i,is_ter) = SQRT(lmt_rug(i)**2+rugoro(i)**2)
+         frugs(i,is_lic) = rugoro(i)
+         frugs(i,is_oce) = rugmer(i)
+         frugs(i,is_sic) = 0.001
+         zxrugs(i) = 0.0
+      ENDDO
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         frugs(i,nsrf) = MAX(frugs(i,nsrf),0.001)
+      ENDDO
+      ENDDO
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         zxrugs(i) = zxrugs(i) + frugs(i,nsrf)*pctsrf(i,nsrf)
+      ENDDO
+      ENDDO
+c
+      CALL clmain(dtime,pctsrf,
+     e            t_seri,q_seri,u_seri,v_seri,soil_model,
+     e            ftsol,soilcap,soilflux,paprs,pplay,radsol,
+     e            fsnow,fqsol,
+     e            rlat, frugs,
+     s            d_t_vdf,d_q_vdf,d_u_vdf,d_v_vdf,d_ts,
+     s            fluxt,fluxq,fluxu,fluxv,cdragh,cdragm,rugmer,
+     s            dsens, devap,
+     s            ycoefh,yu1,yv1) 
+c
+      DO i = 1, klon
+         sens(i) = - fluxt(i,1) ! flux de chaleur sensible au sol
+         evap(i) = - fluxq(i,1) ! flux d'evaporation au sol
+         fder(i) = dsens(i) + devap(i)
+      ENDDO
+      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
+c Incrementer la temperature du sol
+c
+      DO i = 1, klon
+         zxtsol(i) = 0.0
+      ENDDO
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         ftsol(i,nsrf) = ftsol(i,nsrf) + d_ts(i,nsrf)
+         zxtsol(i) = zxtsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+      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)
+      ENDDO
+      ENDDO
+
+c
+c Appeler le modele du sol
+c
+      IF (soil_model) THEN
+         DO nsrf = 1, nbsrf
+         CALL soil(dtime, nsrf, fsnow(1,nsrf),
+     .             ftsol(1,nsrf), ftsoil(1,1,nsrf),
+     .             soilcap(1,nsrf), soilflux(1,nsrf))
+         ENDDO
+      ENDIF
+c
+c Calculer la derive du flux infrarouge
+c
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         fder(i) = fder(i) - 4.0*RSIGMA*zxtsol(i)**3 *
+     .                       (ftsol(i,nsrf)-zxtsol(i))
+     .                      *pctsrf(i,nsrf)
+      ENDDO
+      ENDDO
+c
+c Appeler la convection (au choix)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_qx_dyn(i,k,ivap) 
+     .               + 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
+         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"avantcon=")
+      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, fluxq(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)
+      DO i = 1, klon
+         ibas_con(i) = klev+1 - kcbot(i)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.EQ.3) THEN
+          stop'reactiver le call conlmd dans physiq.F'
+c     CALL conccm (dtime,paprs,pplay,t_seri,q_seri,conv_q,
+c    s             d_t_con, d_q_con, 
+c    s             rain_con, snow_con, ibas_con, itop_con)
+      ELSE
+      PRINT*, "iflag_con non-prevu", iflag_con
+      CALL abort
+      ENDIF
+      CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+     .              d_u_con, d_v_con)
+      DO k = 1, klev
+      DO i = 1, klon
+         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
+      IF (check) THEN
+         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"aprescon=")
+         zx_t = 0.0
+         DO i = 1, klon
+            zx_t = zx_t + rain_con(i)+snow_con(i)
+         ENDDO
+         zx_t = zx_t/FLOAT(klon)*dtime
+         PRINT*, "Precip=", zx_t
+      ENDIF
+c
+      IF (nqmax.GT.2) THEN !--melange convectif de traceurs
+c
+      IF (iflag_con.NE.2) THEN
+         PRINT*, "Pour l instant, seul conflx fonctionne avec traceurs"
+         PRINT*,' Mettre iflag_con = 2  dans  run.def et repasser  !'
+         CALL abort
+      ENDIF
+c
+      ENDIF !--nqmax.GT.2
+c
+c Appeler l'ajustement sec
+c
+C appel supprime pour le moment
+c
+c Appeler le processus de condensation a grande echelle
+c et le processus de precipitation
+c
+      CALL fisrtilp_tr(dtime,paprs,pplay,
+     .           t_seri, q_seri,
+     .           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 )
+      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
+         CALL qcheck(klon,klev,paprs,q_seri,ql_seri,"apresilp=")
+         zx_t = 0.0
+         DO i = 1, klon
+            zx_t = zx_t + rain_lsc(i)+snow_lsc(i)
+         ENDDO
+         zx_t = zx_t/FLOAT(klon)*dtime
+         PRINT*, "Precip=", zx_t
+      ENDIF
+c
+c Nuages diagnostiques:
+c
+      IF (iflag_con.EQ.2) THEN ! seulement pour Tiedtke
+      CALL diagcld(paprs,pplay,t_seri,q_seri,
+     .             rain_con,snow_con,ibas_con,itop_con,
+     .             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+c
+c 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
+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
+      ENDDO
+      ENDDO
+c
+c Calculer les parametres optiques des nuages et quelques
+c parametres pour diagnostiques:
+c
+      CALL nuage (paprs, pplay,
+     .            t_seri, cldliq, cldfra, cldtau, cldemi,
+     .            cldh, cldl, cldm, cldt, cldq)
+c
+c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+      CALL orbite(FLOAT(julien),zlongi,dist)
+      IF (cycle_diurne) THEN
+        zdtime=dtime*FLOAT(radpas) ! pas de temps du rayonnement (s)
+        CALL zenang(zlongi,gmtime,zdtime,rlat,rlon,rmu0,fract)
+c        CALL zenith(zlongi,gmtime,rlat,rlon,rmu0,fract) !va disparaitre
+        CALL alboc_cd(rmu0,alb_eau)
+      ELSE
+        CALL angle(zlongi,rlat,fract,rmu0)
+        CALL alboc(FLOAT(julien),rlat,alb_eau)
+      ENDIF
+      CALL albsno(veget,agesno,alb_neig)
+      DO i = 1, klon
+         zx_alb_oce = alb_eau(i)
+         IF (pctsrf(i,is_oce).GT.epsfra .AND. ftsol(i,is_oce).LT.271.35)
+     .   zx_alb_oce = 0.6 ! pour slab_ocean
+         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_lic)/(fsnow(i,is_lic)+10.0)))
+         zx_alb_lic = alb_neig(i)*zfra + 0.6*(1.0-zfra)
+         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_ter)/(fsnow(i,is_ter)+10.0)))
+         zx_alb_ter = alb_neig(i)*zfra + lmt_alb(i)*(1.0-zfra)
+         zfra = MAX(0.0,MIN(1.0,fsnow(i,is_sic)/(fsnow(i,is_sic)+10.0)))
+         zx_alb_sic = alb_neig(i)*zfra + 0.6*(1.0-zfra)
+         albsol(i) = zx_alb_oce * pctsrf(i,is_oce)
+     .             + zx_alb_lic * pctsrf(i,is_lic)
+     .             + zx_alb_ter * pctsrf(i,is_ter)
+     .             + zx_alb_sic * pctsrf(i,is_sic)
+      ENDDO
+      CALL radlwsw ! nouveau rayonnement (compatible Arpege-IFS)
+     e            (dist, rmu0, fract, co2_ppm, solaire,
+     e             paprs, pplay,zxtsol,albsol, t_seri,q_seri,wo,
+     e             cldfra, cldemi, cldtau,
+     s             heat,heat0,cool,cool0,radsol,albpla,
+     s             topsw,toplw,solsw,sollw,
+     s             topsw0,toplw0,solsw0,sollw0)
+      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
+c Calculer l'hydrologie de la surface
+c
+      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, evap,
+     .            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
+      DO nsrf = 1, nbsrf
+      DO i = 1, klon
+         IF (pctsrf(i,nsrf).LT.epsfra) THEN
+            fqsol(i,nsrf) = zxqsol(i)
+            fsnow(i,nsrf) = zxsnow(i)
+         ENDIF
+      ENDDO
+      ENDDO
+c
+c Calculer le bilan du sol et la derive de temperature (couplage)
+c
+      DO i = 1, klon
+         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+      ENDDO
+      IF (ok_ocean) THEN
+         DO i = 1, klon
+            cthermiq = cyang
+            IF (ftsol(i,is_oce).LT. 271.35) cthermiq = cbing
+            IF (pctsrf(i,is_oce).GT.epsfra) deltat(i) = deltat(i) +
+     .                          (bils(i)-lmt_bils(i))/cthermiq * dtime
+            IF (deltat(i).GT.15.0 ) deltat(i) = 15.0
+            IF (deltat(i).LT.-15.0) deltat(i) = -15.0
+         ENDDO
+      ENDIF
+c
+cmoddeblott(jan95)
+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
+        igwdim=MAX(1,igwd)
+c
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,
+     e                   zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,igwdim,idx,itest,
+     e                   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
+        igwdim=MAX(1,igwd)
+c
+        CALL lift_noro(klon,klev,dtime,paprs,pplay,
+     e                   rlat,zmea,zstd, zsig, zgam, zthe,zpic,zval,
+     e                   igwd,igwdim,idx,itest,
+     e                   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
+cAA
+cAA Installation de l'interface online-offline pour traceurs
+cAA
+c====================================================================
+c   Calcul  des tendances traceurs
+c====================================================================
+CMAF modif pour garder info du nombre de traceurs auxquels
+C la physique s'applique
+C
+      call phytrac (rnpb,
+     I                   debut,
+     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)
+
+      IF (offline) THEN
+      call phystoke (
+     I                   nlon,nlev,pdtphys,
+     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   ycoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa, frac_nucl)
+
+      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
+      IF (ok_oasis) THEN ! couplage oasis
+      DO i = 1, klon
+        oas_sols(i) = oas_sols(i) + solsw(i)          / FLOAT(nexca)
+        oas_nsol(i) = oas_nsol(i) + (bils(i)-solsw(i))/ FLOAT(nexca)
+        oas_rain(i) = oas_rain(i) + rain_fall(i)      / FLOAT(nexca)
+        oas_snow(i) = oas_snow(i) + snow_fall(i)      / FLOAT(nexca)
+        oas_evap(i) = oas_evap(i) + evap(i)           / FLOAT(nexca)
+        oas_tsol(i) = oas_tsol(i) + zxtsol(i)         / FLOAT(nexca)
+        oas_fder(i) = oas_fder(i) + fder(i)           / FLOAT(nexca)
+        oas_albe(i) = oas_albe(i) + albsol(i)         / FLOAT(nexca)
+        oas_taux(i) = oas_taux(i) + fluxu(i,1)        / FLOAT(nexca)
+        oas_tauy(i) = oas_tauy(i) + fluxv(i,1)        / FLOAT(nexca)
+        oas_ruis(i) = oas_ruis(i) + ruis(i)       /FLOAT(nexca)/dtime
+      ENDDO
+      ENDIF
+c
+c
+      IF (ok_journe) THEN
+c
+      ndex(1) = 0
+c
+c Champs 2D:
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_day,"tsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"rain",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, snow_fall,zx_tmp_2d)
+      CALL histwrite(nid_day,"snow",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, evap,zx_tmp_2d)
+      CALL histwrite(nid_day,"evap",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw,zx_tmp_2d)
+      CALL histwrite(nid_day,"tops",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_day,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_day,"sols",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_day,"soll",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, bils,zx_tmp_2d)
+      CALL histwrite(nid_day,"bils",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sens,zx_tmp_2d)
+      CALL histwrite(nid_day,"sens",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, fder,zx_tmp_2d)
+      CALL histwrite(nid_day,"fder",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ruis,zx_tmp_2d)
+      CALL histwrite(nid_day,"ruis",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = fluxu(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"frtu",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = fluxv(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"frtv",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day,"sicf",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldm,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldh,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldt,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldt",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldq,zx_tmp_2d)
+      CALL histwrite(nid_day,"cldq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+c Champs 3D:
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"temp",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite(nid_day,"ovap",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
+      CALL histwrite(nid_day,"geop",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitu",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitv",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, omega, zx_tmp_3d)
+      CALL histwrite(nid_day,"vitw",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
+      CALL histwrite(nid_day,"pres",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      if (ok_sync) call histsync
+      ENDIF
+C
+      IF (ok_mensuel) THEN
+c
+      ndex(1) = 0
+c
+c Champs 2D:
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxtsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zxqsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"qsol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"rain",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"plul",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"pluc",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, snow_fall,zx_tmp_2d)
+      CALL histwrite(nid_mth,"snow",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, agesno,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ages",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, evap,zx_tmp_2d)
+      CALL histwrite(nid_mth,"evap",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, topsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"tops0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"topl0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, solsw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sols0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sollw0,zx_tmp_2d)
+      CALL histwrite(nid_mth,"soll0",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, bils,zx_tmp_2d)
+      CALL histwrite(nid_mth,"bils",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, sens,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sens",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, fder,zx_tmp_2d)
+      CALL histwrite(nid_mth,"fder",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ruis,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ruis",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = fluxu(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"frtu",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = fluxv(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"frtv",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_mth,"sicf",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, albsol,zx_tmp_2d)
+      CALL histwrite(nid_mth,"albs",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cdragm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cdragh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cdrh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldl,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldm,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldm",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldh,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldh",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldt,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldt",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, cldq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"cldq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ue,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ue",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, ve,zx_tmp_2d)
+      CALL histwrite(nid_mth,"ve",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, uq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"uq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, vq,zx_tmp_2d)
+      CALL histwrite(nid_mth,"vq",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+c Champs 3D:
+C
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"temp",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,ivap), zx_tmp_3d)
+      CALL histwrite(nid_mth,"ovap",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
+      CALL histwrite(nid_mth,"geop",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitu",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitv",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, omega, zx_tmp_3d)
+      CALL histwrite(nid_mth,"vitw",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
+      CALL histwrite(nid_mth,"pres",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cldfra, zx_tmp_3d)
+      CALL histwrite(nid_mth,"rneb",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zx_rh, zx_tmp_3d)
+      CALL histwrite(nid_mth,"rhum",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cldliq, zx_tmp_3d)
+      CALL histwrite(nid_mth,"oliq",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_dyn, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtdyn",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_qx_dyn(1,1,ivap),
+     .                 zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqdyn",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_con, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtcon",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_con, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqcon",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_lsc, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlsc",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_lsc, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqlsc",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtvdf",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqvdf",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_eva, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dteva",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_eva, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dqeva",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+C      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_t_ajs, zx_tmp_3d)
+C      CALL histwrite(nid_mth,"dtajs",itap,zx_tmp_3d,
+C    .                                   iim*(jjm+1)*klev,ndex)
+c
+C      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_q_ajs, zx_tmp_3d)
+C      CALL histwrite(nid_mth,"dqajs",itap,zx_tmp_3d,
+C     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, heat, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtswr",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, heat0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtsw0",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cool, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlwr",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, cool0, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dtlw0",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"duvdf",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_vdf, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvvdf",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      IF (ok_orodr) THEN
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_oro, zx_tmp_3d)
+      CALL histwrite(nid_mth,"duoro",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_oro, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvoro",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      ENDIF
+C
+      IF (ok_orolf) THEN
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_u_lif, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dulif",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, d_v_lif, zx_tmp_3d)
+      CALL histwrite(nid_mth,"dvlif",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+      ENDIF
+C
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, wo, zx_tmp_3d)
+      CALL histwrite(nid_mth,"ozone",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      IF (nqmax.GE.3) THEN
+      DO iq=1,nqmax-2
+      IF (iq.LE.99) THEN
+         CALL gr_fi_ecrit(klev,klon,iim,jjm+1, qx(1,1,iq+2), zx_tmp_3d)
+         WRITE(str2,'(i2.2)') iq
+         CALL histwrite(nid_mth,"trac"//str2,itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+      ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ENDIF
+      ENDDO
+      ENDIF
+c
+      if (ok_sync) call histsync
+      ENDIF
+c
+      IF (ok_instan) THEN
+c
+      ndex(1) = 0
+c
+c Champs 2D:
+c
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_ins,"psol",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+      CALL gr_fi_ecrit(1, klon,iim,jjm+1, toplw,zx_tmp_2d)
+      CALL histwrite(nid_ins,"topl",itap,zx_tmp_2d,iim*(jjm+1),ndex)
+c
+c Champs 3D:
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, t_seri, zx_tmp_3d)
+      CALL histwrite(nid_ins,"temp",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, u_seri, zx_tmp_3d)
+      CALL histwrite(nid_ins,"vitu",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, v_seri, zx_tmp_3d)
+      CALL histwrite(nid_ins,"vitv",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, zphi, zx_tmp_3d)
+      CALL histwrite(nid_ins,"geop",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      CALL gr_fi_ecrit(klev,klon,iim,jjm+1, pplay, zx_tmp_3d)
+      CALL histwrite(nid_ins,"pres",itap,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+c
+      if (ok_sync) call histsync
+      ENDIF
+c
+      IF (ok_oasis .AND. mod(itap,nexca).EQ.0) THEN
+c
+c Je ne traite pas le ruissellement, pour l'instant (qui m'aidera ?)
+         DO i = 1, klon
+            oas_ruisoce(i) = 0.0
+            oas_ruisriv(i) = 0.0
+         ENDDO
+c
+         ig = 1
+         DO i = 1, iim
+            z_sols(i,1) = oas_sols(ig)
+            z_nsol(i,1) = oas_nsol(ig)
+            z_rain(i,1) = oas_rain(ig)
+            z_snow(i,1) = oas_snow(ig)
+            z_evap(i,1) = oas_evap(ig)
+            z_ruisoce(i,1) = oas_ruisoce(ig)
+            z_ruisriv(i,1) = oas_ruisriv(ig)
+            z_tsol(i,1) = oas_tsol(ig)
+            z_fder(i,1) = oas_fder(ig)
+            z_albe(i,1) = oas_albe(ig)
+            z_taux(i,1) = oas_taux(ig)
+            z_tauy(i,1) = oas_tauy(ig)
+         ENDDO
+         DO j = 2, jjm
+         DO i = 1, iim
+            ig = ig + 1
+            z_sols(i,j) = oas_sols(ig)
+            z_nsol(i,j) = oas_nsol(ig)
+            z_rain(i,j) = oas_rain(ig)
+            z_snow(i,j) = oas_snow(ig)
+            z_evap(i,j) = oas_evap(ig)
+            z_ruisoce(i,j) = oas_ruisoce(ig)
+            z_ruisriv(i,j) = oas_ruisriv(ig)
+            z_tsol(i,j) = oas_tsol(ig)
+            z_fder(i,j) = oas_fder(ig)
+            z_albe(i,j) = oas_albe(ig)
+            z_taux(i,j) = oas_taux(ig)
+            z_tauy(i,j) = oas_tauy(ig)
+         ENDDO
+         ENDDO
+         ig = ig + 1
+         DO i = 1, iim
+            z_sols(i,jjm+1)    = oas_sols(ig)
+            z_nsol(i,jjm+1)    = oas_nsol(ig)
+            z_rain(i,jjm+1)    = oas_rain(ig)
+            z_snow(i,jjm+1)    = oas_snow(ig)
+            z_evap(i,jjm+1)    = oas_evap(ig)
+            z_ruisoce(i,jjm+1) = oas_ruisoce(ig)
+            z_ruisriv(i,jjm+1) = oas_ruisriv(ig)
+            z_tsol(i,jjm+1)    = oas_tsol(ig)
+            z_fder(i,jjm+1)    = oas_fder(ig)
+            z_albe(i,jjm+1)    = oas_albe(ig)
+            z_taux(i,jjm+1)    = oas_taux(ig)
+            z_tauy(i,jjm+1)    = oas_tauy(ig)
+         ENDDO
+c
+c Passer les champs au coupleur:
+c
+         CALL intocpl(itap,(jjm+1)*iim,
+     .                   z_sols, z_nsol,
+     .                   z_rain, z_snow, z_evap,
+     .                   z_ruisoce, z_ruisriv,
+     .                   z_tsol, z_fder, z_albe,
+     .                   z_taux, z_tauy)
+         DO i = 1, klon
+           oas_sols(i) = 0.0
+           oas_nsol(i) = 0.0
+           oas_rain(i) = 0.0
+           oas_snow(i) = 0.0
+           oas_evap(i) = 0.0
+           oas_ruis(i) = 0.0
+           oas_tsol(i) = 0.0
+           oas_fder(i) = 0.0
+           oas_albe(i) = 0.0
+           oas_taux(i) = 0.0
+           oas_tauy(i) = 0.0
+         ENDDO
+      ENDIF
+c
+c Ecrire la bande regionale (binaire grads)
+      IF (ok_region .AND. mod(itap,ecrit_reg).eq.0) THEN
+         CALL ecriregs(84,zxtsol)
+         CALL ecriregs(84,paprs(1,1))
+         CALL ecriregs(84,topsw)
+         CALL ecriregs(84,toplw)
+         CALL ecriregs(84,solsw)
+         CALL ecriregs(84,sollw)
+         CALL ecriregs(84,rain_fall)
+         CALL ecriregs(84,snow_fall)
+         CALL ecriregs(84,evap)
+         CALL ecriregs(84,sens)
+         CALL ecriregs(84,bils)
+         CALL ecriregs(84,pctsrf(1,is_sic))
+         CALL ecriregs(84,fluxu(1,1))
+         CALL ecriregs(84,fluxv(1,1))
+         CALL ecriregs(84,ue)
+         CALL ecriregs(84,ve)
+         CALL ecriregs(84,uq)
+         CALL ecriregs(84,vq)
+c
+         CALL ecrirega(84,u_seri)
+         CALL ecrirega(84,v_seri)
+         CALL ecrirega(84,omega)
+         CALL ecrirega(84,t_seri)
+         CALL ecrirega(84,zphi)
+         CALL ecrirega(84,q_seri)
+         CALL ecrirega(84,cldfra)
+         CALL ecrirega(84,cldliq)
+         CALL ecrirega(84,pplay)
+
+
+cc         CALL ecrirega(84,d_t_dyn)
+cc         CALL ecrirega(84,d_q_dyn)
+cc         CALL ecrirega(84,heat)
+cc         CALL ecrirega(84,cool)
+cc         CALL ecrirega(84,d_t_con)
+cc         CALL ecrirega(84,d_q_con)
+cc         CALL ecrirega(84,d_t_lsc)
+cc         CALL ecrirega(84,d_q_lsc)
+      ENDIF
+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====================================================================
+c Si c'est la fin, il faut conserver l'etat de redemarrage
+c====================================================================
+c
+      IF (lafin) THEN
+         IF (ok_oasis) CALL quitcpl
+         CALL phyredem ("restartphy.nc",dtime,radpas,co2_ppm,solaire,
+     .        rlat,rlon,ftsol,ftsoil,deltat,fqsol,fsnow,
+     .        radsol,rugmer,agesno,
+     .        zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro)
+      ENDIF
+
+      RETURN
+      END
+      SUBROUTINE qcheck(klon,klev,paprs,q,ql,marque)
+      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)
+      CHARACTER *(*) marque
+      REAL qtotal
+      INTEGER i, k
+c
+      qtotal = 0.0
+      DO k = 1, klev
+      DO i = 1, klon
+         qtotal = qtotal + (q(i,k)+ql(i,k))
+     .                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+c
+      PRINT*, "Eau totale ",marque, qtotal/FLOAT(klon)
+c
+      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, j, n, ig
+c
+      jjm = jjmp1 - 1
+      DO n = 1, nfield
+         DO i=1,iim
+            ecrit(i,1,n) = fi(1,n)
+            ecrit(i,jjm+1,n) = fi(nlon,n)
+         ENDDO
+         DO j = 2, jjm
+            ig = 2+(j-2)*iim
+            DO i = 1, iim
+               ecrit(i,j,n) = fi(ig-1+i,n)
+            ENDDO
+         ENDDO
+      ENDDO
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/phystoke.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phystoke.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/phystoke.F	(revision 3)
@@ -0,0 +1,214 @@
+      SUBROUTINE phystoke (
+     I                   nlon,nlev,pdtphys,
+     I                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     I                   pcoefh,yu1,yv1,ftsol,pctsrf,
+     I                   frac_impa,frac_nucl)
+      IMPLICIT none
+
+c======================================================================
+c Auteur(s) FH
+c Objet: Moniteur general des tendances traceurs
+c
+
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "tracstoke.h"
+#include "indicesol.h"
+c======================================================================
+
+c Arguments:
+c
+c   EN ENTREE:
+c   ==========
+c
+c   divers:
+c   -------
+c
+      integer nlon ! nombre de points horizontaux
+      integer nlev ! nombre de couches verticales
+      real pdtphys ! pas d'integration pour la physique (seconde)
+c
+c   convection:
+c   -----------
+c
+      REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+      REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+      REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+c
+c   Couche limite:
+c   --------------
+c
+      REAL pcoefh(klon,klev)    ! coeff melange CL
+      REAL yv1(klon)
+      REAL yu1(klon)
+c
+c   Lessivage:
+c   ----------
+c
+      REAL frac_impa(klon,klev)
+      REAL frac_nucl(klon,klev)
+c
+c Arguments necessaires pour les sources et puits de traceur
+C
+      real ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+      real pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+
+c======================================================================
+c
+      INTEGER i, k
+c
+      REAL mfu(klon,klev)  ! flux de masse dans le panache montant
+      REAL mfd(klon,klev)  ! flux de masse dans le panache descendant
+      REAL en_u(klon,klev) ! flux entraine dans le panache montant
+      REAL de_u(klon,klev) ! flux detraine dans le panache montant
+      REAL en_d(klon,klev) ! flux entraine dans le panache descendant
+      REAL de_d(klon,klev) ! flux detraine dans le panache descendant
+      REAL coefh(klon,klev) ! flux detraine dans le panache descendant
+
+      REAL pyu1(klon),pyv1(klon)
+      REAL pftsol(klon,nbsrf),ppsrf(klon,nbsrf)
+
+      REAL dtcum
+
+      integer iadvtr,irec
+      real zmin,zmax
+
+      save mfu,mfd,en_u,de_u,en_d,de_d,coefh,dtcum
+      save iadvtr,irec
+      save pyu1,pyv1,pftsol,ppsrf
+
+      data iadvtr,irec/0,1/
+c
+c   Couche limite:
+c======================================================================
+
+      print*,'iadvtr= ',iadvtr
+      print*,'istphy= ',istphy
+      print*,'istdyn= ',istdyn
+
+      IF (iadvtr.eq.0) THEN
+#ifdef CRAY
+         CALL ASSIGN("assign -N ieee -F null f:physique")
+#endif
+         open(49,file='physique',form='unformatted',
+     s        access='direct',recl=4*klon*(9*klev+2+2*nbsrf))
+      ENDIF
+c
+      iadvtr=iadvtr+1
+c
+      IF(mod(iadvtr,istphy).eq.0) THEN 
+c
+c   normalisation par le temps cumule
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=mfu(i,k)/dtcum
+               mfd(i,k)=mfd(i,k)/dtcum
+               en_u(i,k)=en_u(i,k)/dtcum
+               de_u(i,k)=de_u(i,k)/dtcum
+               en_d(i,k)=en_d(i,k)/dtcum
+               de_d(i,k)=de_d(i,k)/dtcum
+               coefh(i,k)=coefh(i,k)/dtcum
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)/dtcum
+            pyu1(i)=pyu1(i)/dtcum
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)/dtcum
+               ppsrf(i,k)=ppsrf(i,k)/dtcum
+            enddo
+         enddo
+c
+c   ecriture des champs
+c
+         irec=irec+1
+         write(49,rec=1) float(irec),float(istphy),
+     s    float(klon),float(klev)
+         write(49,rec=irec) mfu,mfd,en_u,de_u,en_d,de_d
+     s        ,coefh
+     s        ,frac_impa,frac_nucl
+     s        ,pyu1,pyv1,pftsol,ppsrf
+c
+cAA Test sur la valeur des coefficients de lessivage 
+c
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_nucl(i,k))
+                  zmin=min(zmin,frac_nucl(i,k))
+            enddo
+         enddo
+         Print*,'------ coefs de lessivage (min et max) --------'
+         Print*,'facteur de nucleation ',zmin,zmax
+         zmin=1e33
+         zmax=-1e33
+         do k=1,klev
+            do i=1,klon
+                  zmax=max(zmax,frac_impa(i,k))
+                  zmin=min(zmin,frac_impa(i,k))
+            enddo
+         enddo
+         Print*,'facteur d impaction ',zmin,zmax
+
+      ENDIF 
+
+c   reinitialisation des champs cumules
+      if (mod(iadvtr,istphy).eq.1) then
+         do k=1,klev
+            do i=1,klon
+               mfu(i,k)=0.
+               mfd(i,k)=0.
+               en_u(i,k)=0.
+               de_u(i,k)=0.
+               en_d(i,k)=0.
+               de_d(i,k)=0.
+               coefh(i,k)=0.
+            enddo
+         enddo
+         do i=1,klon
+            pyv1(i)=0.
+            pyu1(i)=0.
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=0.
+               ppsrf(i,k)=0.
+            enddo
+         enddo
+
+         dtcum=0.
+      endif
+
+      do k=1,klev
+         do i=1,klon
+            mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+            mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+            en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+            de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+            en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+            de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+            coefh(i,k)=coefh(i,k)+pcoefh(i,k)*pdtphys
+         enddo
+      enddo
+         do i=1,klon
+            pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+            pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+         end do
+         do k=1,nbsrf
+             do i=1,klon
+               pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+               ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+            enddo
+         enddo
+
+      dtcum=dtcum+pdtphys
+
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/phytrac.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/phytrac.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/phytrac.F	(revision 3)
@@ -0,0 +1,533 @@
+      SUBROUTINE phytrac (rnpb,
+     I                   debutphy,
+     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
+      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 "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 znivsig(klev) ! niveaux sigma
+      real paire(klon)
+      real pphis(klon)
+      logical debutphy       ! le flag de l'initialisation 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)
+
+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
+      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   
+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
+
+      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
+     s     /.true.,.true.,.true.,.true.,.true./
+c
+c======================================================================
+c         ecrit_tra = NINT(86400./pdtphys *1.0)  ! tous les jours
+         modname='phytrac'
+
+         print*,'DANS PHYTRAC debutphy=',debutphy
+
+         ecrit_tra = NINT(86400./pdtphys *ecritphy)   
+         if (debutphy) then
+
+         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
+C         
+         CALL ymds2ju(anneeref, 1, 1, 0.0, zjulian)
+         zjulian = zjulian + dayref
+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
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjm+1,xlat,zx_lat)
+         CALL histbeg("histrac", iim,zx_lon, jjm+1,zx_lat,
+     .                 1,iim,1,jjm+1, 0, zjulian, pdtphys,
+     .                 nhori, nid_tra)
+         call histvert(nid_tra, 'sig_s', 'Niveaux sigma','-',
+     .              klev, znivsig, nvert)
+C
+C         CALL histvert(nid_tra, "presnivs", "Vertical levels", "mb",
+C     .                 klev, presnivs, nvert)
+         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)
+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======================================================================
+c   Initialisation de certaines variables pour le Rn et le Pb 
+c======================================================================
+
+c Initialisation du traceur dans le sol (couche limite radonique)
+c
+         print*,'valeur de debut dans phytrac :',debutphy
+         do it=1,nqmax
+            do i=1,klon
+               trs(i,it) = 0.
+            enddo
+         END DO
+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
+c======================================================================
+c   Calcul de l'effet de la convection
+c======================================================================
+
+      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
+      WRITE(itn,'(i1)') it
+      CALL minmaxqfi(tr_seri(1,1,it),0.,1.e33,'convection it='//itn)
+      ENDDO
+      print*,'apres nflxtr'
+
+
+      endif ! convection
+
+c======================================================================
+c   Calcul de l'effet de la couche limite
+c======================================================================
+
+      print*,'avant couchelimite'
+      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
+      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
+
+      print*,'apres couchelimite'
+
+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======================================================================
+
+      IF (lessivage) THEN
+
+      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
+       DO it = 1, nqmax
+         IF (aerosol(it)) THEN
+           DO k = 1, nlev
+              DO i = 1, klon
+               tr_seri(i,k,it) = tr_seri(i,k,it) *
+     s              ( frac_impa(i,k) + frac_nucl(i,k) - 1. )    
+              ENDDO
+           ENDDO
+         ENDIF
+       ENDDO
+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
+      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)
+       IF (lessivage) THEN
+       CALL gr_fi_ecrit(klev,klon,iim,jjm+1,flestottr(1,1,it),zx_tmp_3d)
+       CALL histwrite(nid_tra,"fl"//str2,itra,zx_tmp_3d,
+     .                                   iim*(jjm+1)*klev,ndex)
+      ENDIF
+      ELSE
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ENDIF
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/printflag.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/printflag.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/printflag.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/raddim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/raddim.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/raddim.h	(revision 3)
@@ -0,0 +1,2 @@
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: LMDZ.3.3/branches/LF/libf/phylmd/raddimlw.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/raddimlw.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/raddimlw.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/radepsi.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/radepsi.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/radepsi.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/radiornpb.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/radiornpb.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/radiornpb.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/radlwsw.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/radlwsw.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/radlwsw.F	(revision 3)
@@ -0,0 +1,6144 @@
+      SUBROUTINE radlwsw(dist, rmu0, fract, co2_ppm, solaire,
+     .                  paprs, pplay,tsol,albedo, t,q,wo,
+     .                  cldfra, cldemi, cldtau,
+     .                  heat,heat0,cool,cool0,radsol,albpla,
+     .                  topsw,toplw,solsw,sollw,
+     .                  topsw0,toplw0,solsw0,sollw0)
+      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- ray. solaire absorbe au sommet de l'atm.
+c toplw----output-R- ray. IR emis au sommet de l'atmosphere
+c solsw----output-R- ray. solaire net absorbe a la surface
+c sollw----output-R- ray. IR net emis par la surface
+c======================================================================
+#include "dimensions.h"
+#include "dimphy.h"
+#include "raddim.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), 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)
+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 ztopsw0(kdlon), ztoplw0(kdlon)
+      REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
+
+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)
+         PALBP(i,1) = albedo(iof+i)
+         PALBP(i,2) = albedo(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)
+      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)
+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)
+         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
+      DO i = 1, kdlon
+         heat(iof+i,k) = zheat(i,k)
+         cool(iof+i,k) = zcool(i,k)
+         heat0(iof+i,k) = zheat0(i,k)
+         cool0(iof+i,k) = zcool0(i,k)
+      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)
+      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)
+      SAVE ZFSUP, ZFSDN, ZFSUP0, ZFSDN0
+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) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(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)
+      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
+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)
+      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/branches/LF/libf/phylmd/radopt.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/radopt.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/radopt.h	(revision 3)
@@ -0,0 +1,6 @@
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: LMDZ.3.3/branches/LF/libf/phylmd/regdim.h
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/regdim.h	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/regdim.h	(revision 3)
@@ -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/branches/LF/libf/phylmd/soil.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/soil.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/soil.F	(revision 3)
@@ -0,0 +1,231 @@
+      SUBROUTINE soil(ptimestep, indice, 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 "dimphy.h"
+#include "dimsoil.h"
+#include "indicesol.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      REAL ptimestep
+      INTEGER indice
+      REAL ptsrf(klon),ptsoil(klon,nsoilmx),snow(klon)
+      REAL pcapcal(klon),pfluxgrd(klon)
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+      REAL zdz2(nsoilmx),z1(klon)
+      REAL min_period,dalph_soil
+      REAL ztherm_i(klon)
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(nsoilmx)
+      REAL zc(klon,nsoilmx),zd(klon,nsoilmx)
+      REAL lambda
+      SAVE dz1,dz2,zc,zd,lambda
+      LOGICAL firstcall
+      SAVE firstcall
+      REAL isol,isno,iice
+      SAVE isol,isno,iice
+
+      DATA firstcall/.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.)
+
+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, klon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_lic) THEN
+         DO ig = 1, klon
+            ztherm_i(ig)   = iice
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_ter) THEN
+         DO ig = 1, klon
+            ztherm_i(ig)   = isol
+            IF (snow(ig).GT.0.0) ztherm_i(ig)   = isno
+         ENDDO
+      ELSE IF (indice.EQ.is_oce) THEN
+         DO ig = 1, klon
+            ztherm_i(ig)   = iice
+         ENDDO
+      ELSE
+         PRINT*, "valeur d indice non prevue", indice
+         CALL abort
+      ENDIF
+
+
+      IF (firstcall) 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
+
+         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,klon
+            ptsoil(ig,1)=(lambda*zc(ig,1)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1))+1.)
+         ENDDO
+
+c   other temperatures
+         DO jk=1,nsoilmx-1
+            DO ig=1,klon
+               ptsoil(ig,jk+1)=zc(ig,jk)+zd(ig,jk)*ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF !--not firstcall
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+c   ---------------------------------------------------------------
+
+      DO jk=1,nsoilmx
+         zdz2(jk)=dz2(jk)/ptimestep
+      ENDDO
+
+      DO ig=1,klon
+         z1(ig)=zdz2(nsoilmx)+dz1(nsoilmx-1)
+         zc(ig,nsoilmx-1)=zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1(ig)
+         zd(ig,nsoilmx-1)=dz1(nsoilmx-1)/z1(ig)
+      ENDDO
+
+      DO jk=nsoilmx-1,2,-1
+         DO ig=1,klon
+            z1(ig)=1./(zdz2(jk)+dz1(jk-1)+dz1(jk)*(1.-zd(ig,jk)))
+            zc(ig,jk-1)=
+     s      (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*zc(ig,jk))*z1(ig)
+            zd(ig,jk-1)=dz1(jk-1)*z1(ig)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   computation of the surface diffusive flux from ground and
+c   calorific capacity of the ground:
+c   ---------------------------------
+
+      DO ig=1,klon
+         pfluxgrd(ig)=ztherm_i(ig)*dz1(1)*
+     s   (zc(ig,1)+(zd(ig,1)-1.)*ptsoil(ig,1))
+         pcapcal(ig)=ztherm_i(ig)*
+     s   (dz2(1)+ptimestep*(1.-zd(ig,1))*dz1(1))
+         z1(ig)=lambda*(1.-zd(ig,1))+1.
+         pcapcal(ig)=pcapcal(ig)/z1(ig)
+         pfluxgrd(ig)=pfluxgrd(ig)
+     s   +pcapcal(ig)*(ptsoil(ig,1)*z1(ig)-lambda*zc(ig,1)-ptsrf(ig))
+     s   /ptimestep
+      ENDDO
+
+      RETURN
+      END
Index: LMDZ.3.3/branches/LF/libf/phylmd/suphec.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/suphec.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/suphec.F	(revision 3)
@@ -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=4218.
+      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=2106.
+      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/branches/LF/libf/phylmd/transp.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/transp.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/transp.F	(revision 3)
@@ -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/branches/LF/libf/phylmd/wrgradsfi.F
===================================================================
--- LMDZ.3.3/branches/LF/libf/phylmd/wrgradsfi.F	(revision 3)
+++ LMDZ.3.3/branches/LF/libf/phylmd/wrgradsfi.F	(revision 3)
@@ -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/branches/LF/liste_des_sources
===================================================================
--- LMDZ.3.3/branches/LF/liste_des_sources	(revision 3)
+++ LMDZ.3.3/branches/LF/liste_des_sources	(revision 3)
@@ -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/branches/LF/liste_des_sources_f90
===================================================================
--- LMDZ.3.3/branches/LF/liste_des_sources_f90	(revision 3)
+++ LMDZ.3.3/branches/LF/liste_des_sources_f90	(revision 3)
@@ -0,0 +1,22 @@
+       USE IOIPSL
+libf/bibio/initdynav.F
+      USE ioipsl
+libf/bibio/writedynav.F
+       USE IOIPSL
+libf/bibio/inithist.F
+      USE ioipsl
+libf/bibio/writehist.F
+      USE IOIPSL
+libf/dyn3d/gcmtest.F
+      USE IOIPSL
+libf/dyn3d/abort_gcm.F
+      USE ioipsl
+libf/dyn3d/offline.F
+      USE ioipsl
+libf/dyn3d/startvar.F
+      USE IOIPSL
+libf/dyn3d/etat0_netcdf.F
+      USE ioipsl
+libf/phylmd/physiq.F
+      USE ioipsl
+libf/phylmd/phytrac.F
Index: LMDZ.3.3/branches/LF/makegcm
===================================================================
--- LMDZ.3.3/branches/LF/makegcm	(revision 3)
+++ LMDZ.3.3/branches/LF/makegcm	(revision 3)
@@ -0,0 +1,695 @@
+#!/bin/csh
+#set verbose echo
+########################################################################
+# options par defaut pour la commande make
+########################################################################
+set dim="48x32x19"
+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
+########################################################################
+# path a changer contenant les sources et les objets du modele
+########################################################################
+
+###### VERSION LMDZ.3.3
+# set LMDGCM=$HOME/LMDZ.3.3
+#
+#   a changer  rlmd304/agcm
+#
+###### VERSION LMDZ.3.2
+
+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
+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
+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
+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 ( `hostname` == rhodes ) then
+   set machine=NEC
+   set NEC=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 optimbis=" "
+   set optim90=" -fast -fixed "
+   set opt_link="-lf77compat -L$IOIPSLDIR -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=" -Ad -Of -Wv,-Of,-ilfunc"
+   set optimbis=" -Psia -Aa -Wv,-m3 -Wp,-DVPP,-DNC_DOUBLE -Z $LMDGCM/listage"
+   set optim=" -Of -Wv,-Of,-ilfunc"
+   set optimbis=" -Psia -Aa -Wv,-m3 -Wp,-DVPP -Z $LMDGCM/listage"
+   set optim90="$optim""$optimbis"" -X9 -w"
+   set opt_link="-L$IOIPSLDIR -lioipsl  -L$NCDFLIB -lnetcdf"
+   set oplink=" "
+   set mod_loc_dir=$IOIPSLDIR
+   set mod_suffix=mod
+else if $DEC then
+   set optim=" "
+   set optimbis=" "
+else if $LINUX then
+   set optim="-fast "
+   set optim90=" -fast -module $libo"
+   set opt_link=" -Mfree -L/usr/local/pgi/linux86/lib -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$NCDFLIB -lnetcdf -L$IOIPSLDIR -lioipsl -Wl,-Bstatic "
+   set mod_loc_dir=$IOIPSLDIR
+   set mod_suffix=mod
+else if $NEC then
+set optim90=' -C hopt -float0 -ew -R4 -L nostdout -Wf,"-pvctlfullmsg noassume loopcnt=150000 -L transform"'
+   set optim90=' -C hopt -float0 -ew -R4 -L nostdout '
+   set optim="$optim90"
+   set opt_link="-L/u/rech/ces/rces011/ioipsl"
+   set optimbis=" "
+   set mod_loc_dir=" "
+   set mod_suffix=" "
+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
+
+-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 -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="$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 optim90=" -fixed -g "
+        else if $CRAY then
+           set optim="$optim"" -g "
+           set optim90="$optim90"" -G1 "
+        else if $LINUX then
+           set optim="$optim"" -g -Mbounds "
+           set optim90="$optim90"" -g -Mbounds "
+        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 tmp ; touch tmp
+\rm 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
+   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 ) 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
+########################################################################
+
+set include="$include -I$NCDFINC -I$IOIPSLDIR"
+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 $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 $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
+
+########################################################################
+#  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
+
+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
+else if $CRAY then
+   set f77=f90
+   set f90=f90
+else if $LINUX then
+   set f77=pgf77
+   set f90=pgf90
+else if $SUN then
+   set f77=f90
+   set f90=f90
+else if $NEC then
+   set f77=sxf90
+   set f90=sxf90
+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
+set make="make RANLIB=ranlib"
+endif
+
+
+
+set link="$f90 $optim90"
+
+if $NEC then
+  set link="sxld $opt_link"
+  set ar=sxar
+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
+
+#
+# Encore un test temporaire: probleme de compilation sur VPP
+# l'optimisation de startvar se passe mal
+#
+if ($code == 'create_etat0' && $VPP) 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=" -Ad -Wv,-Of,-ilfunc"
+   set optimbis=" -Psia -Aa -Wv,-m3 -Wp,-DVPP,-DNC_DOUBLE -Z $LMDGCM/listage"
+   set optim90="$optim""$optimbis"" -X9 -w"
+   set opt_link="-L$IOIPSLDIR -lioipsl -L$NCDFLIB -lnetcdf"
+   touch $LMDGCM/libf/dyn3d/startvar.F
+   touch $LMDGCM/libf/dyn3d/etat0_netcdf.F
+endif
+
+#################################################################
+# Execution de la comande make... ENFIN!
+#################################################################
+
+if $VPP then
+  set optim90=" $optim90 -Am -M$libo"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $SUN then
+ set optim90=" $optim90 -M$IOIPSLDIR -M$libo "
+ set optim="$optim90"
+ \cp $IOIPSLDIR/*.mod $libo
+else if $LINUX then
+ set optim90=" -fast -module $libo "
+ set mod_loc_dir=$libo
+ \cp $IOIPSLDIR/*.mod $libo
+endif
+
+cd $localdir
+
+
+echo $make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+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 \
+PROG=$code
+
+$make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+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 \
+PROG=$code
+
+\rm $libf/grid/dimensions.h
Index: LMDZ.3.3/branches/LF/offline.def
===================================================================
--- LMDZ.3.3/branches/LF/offline.def	(revision 3)
+++ LMDZ.3.3/branches/LF/offline.def	(revision 3)
@@ -0,0 +1,9 @@
+T
+4
+T
+-2.
+48.1
+1
+T
+6
+2
Index: LMDZ.3.3/branches/LF/proc
===================================================================
--- LMDZ.3.3/branches/LF/proc	(revision 3)
+++ LMDZ.3.3/branches/LF/proc	(revision 3)
@@ -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/branches/LF/run.def.10jours
===================================================================
--- LMDZ.3.3/branches/LF/run.def.10jours	(revision 3)
+++ LMDZ.3.3/branches/LF/run.def.10jours	(revision 3)
@@ -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/branches/LF/script/compdeb
===================================================================
--- LMDZ.3.3/branches/LF/script/compdeb	(revision 3)
+++ LMDZ.3.3/branches/LF/script/compdeb	(revision 3)
@@ -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/branches/LF/script/compile
===================================================================
--- LMDZ.3.3/branches/LF/script/compile	(revision 3)
+++ LMDZ.3.3/branches/LF/script/compile	(revision 3)
@@ -0,0 +1,12 @@
+#QSUB -r lmdzt_compile -eo -o /workdir/rech/hou/rhou909/out.lmdzt_compile
+#QSUB -lM 256Mb -ls 8Mb -lP 0 -lT 01:00:00 -lt 01:00:00 -q compil
+
+set -xv
+
+cd $WORKDIR
+date
+
+$HOME/LMDZ.3.3/makegcm_drs etat0_lmd
+$HOME/LMDZ.3.3/makegcm_drs limit_lmd
+$HOME/LMDZ.3.3/makegcm gcm
+
Index: LMDZ.3.3/branches/LF/script/cp2netcdf
===================================================================
--- LMDZ.3.3/branches/LF/script/cp2netcdf	(revision 3)
+++ LMDZ.3.3/branches/LF/script/cp2netcdf	(revision 3)
@@ -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/branches/LF/script/cpnetcdf
===================================================================
--- LMDZ.3.3/branches/LF/script/cpnetcdf	(revision 3)
+++ LMDZ.3.3/branches/LF/script/cpnetcdf	(revision 3)
@@ -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/branches/LF/script/essai
===================================================================
--- LMDZ.3.3/branches/LF/script/essai	(revision 3)
+++ LMDZ.3.3/branches/LF/script/essai	(revision 3)
@@ -0,0 +1,28 @@
+#QSUB -r lmdz32_essai -eo -o /workdir/rech/ces/rces111/out.lmdz32_essai
+#QSUB -lM 370Mb -ls 8Mb -lP 0 -lT 00:10:00 -lt 00:10:00
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def.2jours run.def
+
+cp $WORKDIR/gcm.e gcm.e ; chmod u+x gcm.e
+#maiaget lmdz32/divers/limit.nc limit7995.nc
+#maiaget lmdz32/divers/start.nc start.nc
+#maiaget lmdz32/divers/startphy.nc startphy.nc
+cp $WORKDIR/limit.nc limit7995.nc
+cp $WORKDIR/start.nc start.nc
+cp $WORKDIR/startphy.nc startphy.nc
+
+timex gcm.e
+ls -lt
+
+cp histday.nc $WORKDIR
+cp histmth.nc $WORKDIR
+cp histins.nc $WORKDIR
+cp histoire.nc $WORKDIR
+cp histmoy.nc $WORKDIR
+cp restart.nc $WORKDIR
+cp restartphy.nc $WORKDIR
Index: LMDZ.3.3/branches/LF/script/initialisation
===================================================================
--- LMDZ.3.3/branches/LF/script/initialisation	(revision 3)
+++ LMDZ.3.3/branches/LF/script/initialisation	(revision 3)
@@ -0,0 +1,51 @@
+#!/bin/csh
+
+# en local
+
+set dir=~lmdz/DATA
+set cp="ln -s"
+
+#===================================================================
+# Fichiers necessaires a la creations des etats initiaux
+#===================================================================
+$cp $dir/albedo.g1x1.dat albed.dat          # Albedos de surface
+$cp $dir/albedo.g1x1.dic albed.dic          
+$cp $dir/amip88.g2x2.dat amip.dat           # SST
+$cp $dir/amip88.g2x2.dic amip.dic
+$cp $dir/ecdyn.d880701.h12.dat ecdyn.dat    # Etat initial dynamique
+$cp $dir/ecdyn.d880701.h12.dic ecdyn.dic
+$cp $dir/ecphy.d880701.h12.dat ecphy.dat    # Etat initial physique
+$cp $dir/ecphy.d880701.h12.dic ecphy.dic
+$cp $dir/relief.usnavy.dat relief.dat       # Fichier de relief
+$cp $dir/relief.usnavy.dic relief.dic
+$cp $dir/rugos.g1x1.dat rugos.dat           # Rugosite de la surface
+$cp $dir/rugos.g1x1.dic rugos.dic
+#===================================================================
+
+
+if ( ! -f run.def ) then
+echo Il faut avoir sur le repertoire courant un fichier run.def
+exit
+endif
+
+# Creation des etats initiaux
+# ===========================
+echo "execution de etat0_lmd.e, sortie dans etat0_lmd.l"
+./etat0_lmd.e << EoD >! etat0_lmd.l
+181
+EoD
+
+# Creation des conditions aux limites
+# ===================================
+echo "execution de limit_lmd.e, sortie dans limit_lmd.l"
+./limit_lmd.e >! limit_lmd.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/branches/LF/script/lancer_essai
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_essai	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_essai	(revision 3)
@@ -0,0 +1,22 @@
+#QSUB -r lmdz32_essai -eo -o /workdir/rech/ces/rces111/out.lmdz32_essai
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 00:30:00 -lt 00:30:00
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def.10jours run.def
+
+mkdir saves
+maiaget lmdz32/divers/gcm.e gcm.e; chmod u+x gcm.e
+maiaget lmdz32/divers/limit.dat limit7995.dat
+maiaget lmdz32/divers/limit.dic limit7995.dic
+maiaget lmdz32/divers/start.dat start.dat
+maiaget lmdz32/divers/start.dic start.dic
+maiaget lmdz32/divers/startphy.dat startphy.dat
+maiaget lmdz32/divers/startphy.dic startphy.dic
+
+gcm.e
+
+ls -lt
Index: LMDZ.3.3/branches/LF/script/lancer_etat0
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_etat0	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_etat0	(revision 3)
@@ -0,0 +1,40 @@
+#QSUB -r lmdz32_etat0 -eo -o /workdir/rech/ces/rces111/out.etat0
+#QSUB -lM 320Mb -ls 8Mb -lP 0 -lT 00:30:00 -lt 00:30:00
+set -x
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def .
+
+maiaget /u/rech/lmd/rlmd001/datadrs/albedo.g1x1.dat albed.dat
+maiaget /u/rech/lmd/rlmd001/datadrs/albedo.g1x1.dic albed.dic
+maiaget /u/rech/lmd/rlmd001/datadrs/rugos.g1x1.dic rugos.dic
+maiaget /u/rech/lmd/rlmd001/datadrs/rugos.g1x1.dat rugos.dat
+maiaget /u/rech/lmd/rlmd001/datadrs/relief.usnavy.dic.Z relief.dic.Z
+maiaget /u/rech/lmd/rlmd001/datadrs/relief.usnavy.dat.Z relief.dat.Z
+maiaget /u/rech/lmd/rlmd001/datadrs/ecphy.d880701.h12.dic ecphy.dic
+maiaget /u/rech/lmd/rlmd001/datadrs/ecphy.d880701.h12.dat ecphy.dat
+maiaget /u/rech/lmd/rlmd001/datadrs/ecdyn.d880701.h12.dic ecdyn.dic
+maiaget /u/rech/lmd/rlmd001/datadrs/ecdyn.d880701.h12.dat ecdyn.dat
+maiaget /u/rech/lmd/rlmd001/datadrs/amip2bc7995.dic.Z amip.dic.Z
+maiaget /u/rech/lmd/rlmd001/datadrs/amip2bc7995.dat.Z amip.dat.Z
+uncompress *.Z
+
+cp $WORKDIR/etat0_lmd.e .
+etat0_lmd.e
+
+cp $WORKDIR/limit_lmd.e .
+limit_lmd.e
+
+ls -lt
+
+for n in start.nc startphy.nc limit.nc
+do
+cp $n $WORKDIR
+maiaput $n lmdz32/divers/$n
+done
+
+
+rsh shine0 qsub lmdz32/script/essai
+
Index: LMDZ.3.3/branches/LF/script/lancer_sim00
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_sim00	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_sim00	(revision 3)
@@ -0,0 +1,49 @@
+#QSUB -r lmdz32_sim00 -eo -o /workdir/rech/ces/rces111/out.lmdz32_sim00
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 09:00:00 -lt 03:00:00
+exp=sim00
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def run.def
+
+mkdir saves
+maiaget lmdz32/${exp}/gcm.e saves/gcm.e; chmod u+x saves/gcm.e
+maiaget lmdz32/divers/limit.dat saves/limit.dat
+maiaget lmdz32/divers/limit.dic saves/limit.dic
+mv run.def saves/run.def
+maiaget lmdz32/divers/start.dat saves/start.dat
+maiaget lmdz32/divers/start.dic saves/start.dic
+maiaget lmdz32/divers/startphy.dat saves/startphy.dat
+maiaget lmdz32/divers/startphy.dic saves/startphy.dic
+
+for m in 1 2 3
+do
+cp saves/gcm.e gcm.e
+cp saves/limit.dat limit7995.dat
+cp saves/limit.dic limit7995.dic
+cp saves/run.def run.def
+mv saves/start.dat .
+mv saves/start.dic .
+mv saves/startphy.dat .
+mv saves/startphy.dic .
+mp1=`expr $m + 1`
+gcm.e || exit 1
+maiaput histphy.dat lmdz32/${exp}/histphy.dat.$m
+maiaput histphy.dic lmdz32/${exp}/histphy.dic.$m
+maiaput relief.gdat lmdz32/${exp}/relief.gdat
+maiaput relief.ctl lmdz32/${exp}/relief.ctl
+maiaput restartphy.dat lmdz32/${exp}/startphy.dat.${mp1}
+maiaput restartphy.dic lmdz32/${exp}/startphy.dic.${mp1}
+maiaput restart.dat lmdz32/${exp}/start.dat.${mp1}
+maiaput restart.dic lmdz32/${exp}/start.dic.${mp1}
+mv restartphy.dat saves/startphy.dat
+mv restartphy.dic saves/startphy.dic
+mv restart.dat saves/start.dat
+mv restart.dic saves/start.dic
+ls -lt
+/bin/rm *
+done
+
Index: LMDZ.3.3/branches/LF/script/lancer_sim01
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_sim01	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_sim01	(revision 3)
@@ -0,0 +1,49 @@
+#QSUB -r lmdz32_sim01 -eo -o /workdir/rech/ces/rces111/out.lmdz32_sim01
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 09:00:00 -lt 03:00:00
+exp=sim01
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def run.def
+
+mkdir saves
+maiaget lmdz32/${exp}/gcm.e saves/gcm.e; chmod u+x saves/gcm.e
+maiaget lmdz32/divers/limit.dat saves/limit.dat
+maiaget lmdz32/divers/limit.dic saves/limit.dic
+mv run.def saves/run.def
+maiaget lmdz32/divers/start.dat saves/start.dat
+maiaget lmdz32/divers/start.dic saves/start.dic
+maiaget lmdz32/divers/startphy.dat saves/startphy.dat
+maiaget lmdz32/divers/startphy.dic saves/startphy.dic
+
+for m in 1 2 3
+do
+cp saves/gcm.e gcm.e
+cp saves/limit.dat limit7995.dat
+cp saves/limit.dic limit7995.dic
+cp saves/run.def run.def
+mv saves/start.dat .
+mv saves/start.dic .
+mv saves/startphy.dat .
+mv saves/startphy.dic .
+mp1=`expr $m + 1`
+gcm.e || exit 1
+maiaput histphy.dat lmdz32/${exp}/histphy.dat.$m
+maiaput histphy.dic lmdz32/${exp}/histphy.dic.$m
+maiaput relief.gdat lmdz32/${exp}/relief.gdat
+maiaput relief.ctl lmdz32/${exp}/relief.ctl
+maiaput restartphy.dat lmdz32/${exp}/startphy.dat.${mp1}
+maiaput restartphy.dic lmdz32/${exp}/startphy.dic.${mp1}
+maiaput restart.dat lmdz32/${exp}/start.dat.${mp1}
+maiaput restart.dic lmdz32/${exp}/start.dic.${mp1}
+mv restartphy.dat saves/startphy.dat
+mv restartphy.dic saves/startphy.dic
+mv restart.dat saves/start.dat
+mv restart.dic saves/start.dic
+ls -lt
+/bin/rm *
+done
+
Index: LMDZ.3.3/branches/LF/script/lancer_sim02
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_sim02	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_sim02	(revision 3)
@@ -0,0 +1,49 @@
+#QSUB -r lmdz32_sim02 -eo -o /workdir/rech/ces/rces111/out.lmdz32_sim02
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 09:00:00 -lt 03:00:00
+exp=sim02
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def run.def
+
+mkdir saves
+maiaget lmdz32/${exp}/gcm.e saves/gcm.e; chmod u+x saves/gcm.e
+maiaget lmdz32/divers/limit.dat saves/limit.dat
+maiaget lmdz32/divers/limit.dic saves/limit.dic
+mv run.def saves/run.def
+maiaget lmdz32/divers/start.dat saves/start.dat
+maiaget lmdz32/divers/start.dic saves/start.dic
+maiaget lmdz32/divers/startphy.dat saves/startphy.dat
+maiaget lmdz32/divers/startphy.dic saves/startphy.dic
+
+for m in 1 2 3
+do
+cp saves/gcm.e gcm.e
+cp saves/limit.dat limit7995.dat
+cp saves/limit.dic limit7995.dic
+cp saves/run.def run.def
+mv saves/start.dat .
+mv saves/start.dic .
+mv saves/startphy.dat .
+mv saves/startphy.dic .
+mp1=`expr $m + 1`
+gcm.e || exit 1
+maiaput histphy.dat lmdz32/${exp}/histphy.dat.$m
+maiaput histphy.dic lmdz32/${exp}/histphy.dic.$m
+maiaput relief.gdat lmdz32/${exp}/relief.gdat
+maiaput relief.ctl lmdz32/${exp}/relief.ctl
+maiaput restartphy.dat lmdz32/${exp}/startphy.dat.${mp1}
+maiaput restartphy.dic lmdz32/${exp}/startphy.dic.${mp1}
+maiaput restart.dat lmdz32/${exp}/start.dat.${mp1}
+maiaput restart.dic lmdz32/${exp}/start.dic.${mp1}
+mv restartphy.dat saves/startphy.dat
+mv restartphy.dic saves/startphy.dic
+mv restart.dat saves/start.dat
+mv restart.dic saves/start.dic
+ls -lt
+/bin/rm *
+done
+
Index: LMDZ.3.3/branches/LF/script/lancer_sim03
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_sim03	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_sim03	(revision 3)
@@ -0,0 +1,49 @@
+#QSUB -r lmdz32_sim03 -eo -o /workdir/rech/ces/rces111/out.lmdz32_sim03
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 09:00:00 -lt 03:00:00
+exp=sim03
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def run.def
+
+mkdir saves
+maiaget lmdz32/${exp}/gcm.e saves/gcm.e; chmod u+x saves/gcm.e
+maiaget lmdz32/divers/limit.dat saves/limit.dat
+maiaget lmdz32/divers/limit.dic saves/limit.dic
+mv run.def saves/run.def
+maiaget lmdz32/divers/start.dat saves/start.dat
+maiaget lmdz32/divers/start.dic saves/start.dic
+maiaget lmdz32/divers/startphy.dat saves/startphy.dat
+maiaget lmdz32/divers/startphy.dic saves/startphy.dic
+
+for m in 1 2 3
+do
+cp saves/gcm.e gcm.e
+cp saves/limit.dat limit7995.dat
+cp saves/limit.dic limit7995.dic
+cp saves/run.def run.def
+mv saves/start.dat .
+mv saves/start.dic .
+mv saves/startphy.dat .
+mv saves/startphy.dic .
+mp1=`expr $m + 1`
+gcm.e || exit 1
+maiaput histphy.dat lmdz32/${exp}/histphy.dat.$m
+maiaput histphy.dic lmdz32/${exp}/histphy.dic.$m
+maiaput relief.gdat lmdz32/${exp}/relief.gdat
+maiaput relief.ctl lmdz32/${exp}/relief.ctl
+maiaput restartphy.dat lmdz32/${exp}/startphy.dat.${mp1}
+maiaput restartphy.dic lmdz32/${exp}/startphy.dic.${mp1}
+maiaput restart.dat lmdz32/${exp}/start.dat.${mp1}
+maiaput restart.dic lmdz32/${exp}/start.dic.${mp1}
+mv restartphy.dat saves/startphy.dat
+mv restartphy.dic saves/startphy.dic
+mv restart.dat saves/start.dat
+mv restart.dic saves/start.dic
+ls -lt
+/bin/rm *
+done
+
Index: LMDZ.3.3/branches/LF/script/lancer_sim04
===================================================================
--- LMDZ.3.3/branches/LF/script/lancer_sim04	(revision 3)
+++ LMDZ.3.3/branches/LF/script/lancer_sim04	(revision 3)
@@ -0,0 +1,39 @@
+#QSUB -r lmdz32_sim04 -eo -o /workdir/rech/ces/rces111/out.lmdz32_sim04
+#QSUB -lM 290Mb -ls 8Mb -lP 0 -lT 09:00:00 -lt 03:00:00
+exp=sim04
+
+set -xv
+
+cd $TMPDIR
+date
+
+cp $HOME/lmdz32/run.def run.def
+
+mkdir saves
+maiaget lmdz32/${exp}/gcm.e saves/gcm.e; chmod u+x saves/gcm.e
+maiaget lmdz32/divers/limit.nc saves/limit.nc
+mv run.def saves/run.def
+maiaget lmdz32/divers/start.nc saves/start.nc
+maiaget lmdz32/divers/startphy.nc saves/startphy.nc
+
+for m in 1 2 3
+do
+cp saves/gcm.e gcm.e
+cp saves/limit.nc limit7995.nc
+cp saves/run.def run.def
+mv saves/start.nc .
+mv saves/startphy.nc .
+mp1=`expr $m + 1`
+gcm.e || exit 1
+maiaput histphy.nc lmdz32/${exp}/histphy.nc.$m
+maiaput histday.nc lmdz32/${exp}/histday.nc.$m
+maiaput relief.gdat lmdz32/${exp}/relief.gdat
+maiaput relief.ctl lmdz32/${exp}/relief.ctl
+maiaput restartphy.nc lmdz32/${exp}/startphy.nc.${mp1}
+maiaput restart.nc lmdz32/${exp}/start.nc.${mp1}
+mv restartphy.nc saves/startphy.nc
+mv restart.nc saves/start.nc
+ls -lt
+/bin/rm *
+done
+
Index: LMDZ.3.3/branches/LF/script/run.def
===================================================================
--- LMDZ.3.3/branches/LF/script/run.def	(revision 3)
+++ LMDZ.3.3/branches/LF/script/run.def	(revision 3)
@@ -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/branches/LF/tmp
===================================================================
--- LMDZ.3.3/branches/LF/tmp	(revision 3)
+++ LMDZ.3.3/branches/LF/tmp	(revision 3)
@@ -0,0 +1,1 @@
+fast
Index: LMDZ.3.3/branches/LF/tmp90
===================================================================
--- LMDZ.3.3/branches/LF/tmp90	(revision 3)
+++ LMDZ.3.3/branches/LF/tmp90	(revision 3)
@@ -0,0 +1,22 @@
+       USE IOIPSL
+libf/bibio/initdynav.F
+      USE ioipsl
+libf/bibio/writedynav.F
+       USE IOIPSL
+libf/bibio/inithist.F
+      USE ioipsl
+libf/bibio/writehist.F
+      USE IOIPSL
+libf/dyn3d/gcmtest.F
+      USE IOIPSL
+libf/dyn3d/abort_gcm.F
+      USE ioipsl
+libf/dyn3d/offline.F
+      USE ioipsl
+libf/dyn3d/startvar.F
+      USE IOIPSL
+libf/dyn3d/etat0_netcdf.F
+      USE ioipsl
+libf/phylmd/physiq.F
+      USE ioipsl
+libf/phylmd/phytrac.F
