Index: trunk/mesoscale/LMDZ.MARS/LMDZ.MARS.source.txt
===================================================================
--- trunk/mesoscale/LMDZ.MARS/LMDZ.MARS.source.txt	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/LMDZ.MARS.source.txt	(revision 57)
@@ -0,0 +1,1 @@
+link ../LMD_MM_MARS/SIMU/in_lmdz_mars/LMDZ.MARS.source.txt
Index: trunk/mesoscale/LMDZ.MARS/compile
===================================================================
--- trunk/mesoscale/LMDZ.MARS/compile	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/compile	(revision 57)
@@ -0,0 +1,1 @@
+link in_lmdz_mars/compile
Index: trunk/mesoscale/LMDZ.MARS/create_make_gcm
===================================================================
--- trunk/mesoscale/LMDZ.MARS/create_make_gcm	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/create_make_gcm	(revision 57)
@@ -0,0 +1,235 @@
+#!/bin/sh
+#set -xv
+#
+# Ehouarn: added the following feature:
+#          create_make_gcm must be called with list of directories
+#          which contain header (or modules) which should be scanned
+#          by create_make_gcm when checking dependencies.
+#          Example:
+#          create_make_gcm dyn3d grid
+#          means that header/modules will be looked for in directories
+#          ., dyn3d and grid
+#
+machine=`hostname`
+os=`uname`
+gcm=`pwd`
+libf=$gcm/libf
+libo=$gcm/libo
+CRAY=0
+if [ "$machine" = "atlas" -o "$machine" = "etoile" -o "$machine" = "axis" ] ; then
+  CRAY=1
+fi
+XNEC=0
+if [ "$machine" = "rhodes" ] ; then
+  XNEC=1
+fi
+VPP=0
+if [ "$machine" = "nymphea0" ] ; then
+  VPP=1
+fi
+#
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Definitions de Macros pour Make"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo 
+echo "# create_make_gcm arguments: $*"
+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 'AERONOMARS    = $(LIBF)/aeronomars'
+echo "FILTRE   = filtre"
+echo "PHYS  = "
+echo 'DYN  = $(DYNTYPE)'
+echo 'LIBPHY = $(LIBO)/libphy$(PHYS).a'
+echo 'DIRMAIN= $(DYN)$(DIM)d'
+echo 'RM=rm'
+echo
+echo "OPLINK = "
+echo
+echo '# Les differentes librairies pour l"edition des liens:'
+echo
+if [ "$XNEC" = '1' ] ; then
+  echo 'dyn3d      = $(LIBO)/libsxdyn3d.a $(LIBO)/libsx$(FILTRE).a'
+  echo 'dyn2d      = $(LIBO)/libsxdyn2d.a'
+  echo 'dyn1d      = $(LIBO)/libsxdyn1d.a'
+  echo 'L_DYN      = -lsxdyn$(DIM)d'
+  echo 'L_FILTRE   = -lsx$(FILTRE)'
+  echo 'L_PHY = -lsxphy$(PHYS) '
+  echo 'L_BIBIO    = -lsxbibio'
+  echo 'L_AERONOMARS    = -lsxaeronomars'
+  echo 'L_ADJNT    ='
+else
+  echo 'dyn3d      = $(LIBO)/libdyn3d.a $(LIBO)/lib$(FILTRE).a'
+  echo 'dyn2d      = $(LIBO)/libdyn2d.a'
+  echo 'dyn1d      = $(LIBO)/libdyn1d.a'
+  echo 'L_DYN      = -l$(DYN)$(DIM)d'
+  echo 'L_FILTRE   = -l$(FILTRE)'
+  echo 'L_PHY = -lphy$(PHYS) '
+  echo 'L_BIBIO    = -lbibio'
+  echo 'L_AERONOMARS    = -laeronomars'
+  echo 'L_ADJNT    ='
+fi
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Option de compilation FORTRAN"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+   echo 'COMPILE90 = $(F90) $(OPTIM90) $(INCLUDE) -c'
+   echo "LINK    = $LINK"
+   echo "AR      = $AR"
+echo
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Creation des differents executables"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo "# Executables:"
+echo "# ------------"
+echo
+echo "PROG = code"
+echo
+echo 'main : $(DYN) bibio phys aeronomars $(OPTION_DEP) '
+echo '	cd $(LIBO) ; $(RANLIB) lib*.a ; cd $(GCM) ;\'
+echo '	cd $(LOCAL_DIR); \'
+echo '	$(COMPILE90) $(LIBF)/$(DIRMAIN)/$(PROG).F -o $(PROG).o ; \'
+if [ "$CRAY" = '0' ] ; then
+echo '	$(LINK) $(PROG).o -L$(LIBO) $(L_DYN) $(L_ADJNT) $(L_FILTRE) $(L_AERONOMARS) $(L_PHY) $(L_BIBIO) $(L_DYN) $(L_AERONOMARS) $(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_AERONOMARS) $(L_PHY) $(L_BIBIO) $(L_DYN) $(L_AERONOMARS) $(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 'olddyn : $(LIBO)/libolddyn$(DIM)d.a $(FILTRE)$(DIM)d'
+echo
+echo 'phys : $(LIBPHY)'
+echo
+echo 'bibio : $(LIBO)/libbibio.a'
+echo
+echo 'aeronomars : $(LIBO)/libaeronomars.a'
+echo
+echo 'adjnt : $(LIBO)/libadjnt.a'
+echo
+echo '$(FILTRE)3d : $(LIBO)/lib$(FILTRE).a'
+echo
+echo '$(FILTRE)2d :'
+echo
+echo '$(FILTRE)1d :'
+echo
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo "# Contenu des differentes bibliotheques"
+echo "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
+echo
+echo
+cd $libf >/dev/null 2>&1
+for diri in ` ls `
+do
+   if [ -d $diri ] ; then
+   if [ "`ls $diri/*.F`" != "" ] || [ "`ls $diri/*.F90`" != "" ]  ; then 
+      cd $diri >/dev/null 2>&1
+      echo
+      listlib=""
+      for i in `ls *.F`
+      do
+         fili=`basename $i .F`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then 
+            listlib=$listlib" "$fili
+         fi
+      done
+      for i in `ls *.F90`
+      do
+         fili=`basename $i .F90`
+         test=` (  head $i | grep '      PROGRAM' ) `
+         if [ "$test" = "" ] ; then
+            listlib=$listlib" "$fili
+         fi 
+      done
+#
+      echo
+      echo
+      echo "#======================================================================="
+      echo "# Contenu de la bibliotheque correspondant au Directory "$diri
+      echo "#======================================================================="
+      echo
+      for fili in $listlib
+      do
+         echo '$(LIBO)/lib'$diri".a : " '$(LIBO)/lib'$diri".a("$fili".o)"
+         echo
+      done
+      echo '.PRECIOUS	: $(LIBO)/lib'$diri'.a'
+      echo
+      echo
+      echo "# Compilation des membres de la bibliotheque lib"$diri".a"
+      echo
+      for fili in $listlib
+      do
+         if [ -f $fili.F90 ] ; then
+           trufile=$fili.F90
+         else
+           trufile=$fili.F
+         fi
+         F90=0 ; egrep -i '^ *use ' $trufile > /dev/null 2>&1 && F90=1
+                 egrep -i '^ *module ' $trufile > /dev/null 2>&1 && F90=1
+         str1='$(LIBO)/lib'$diri'.a('$fili'.o) : $(LIBF)/'$diri/$trufile
+         [ "$fili" = "chem.subs" ] && str1=$str1' $(LIBF)/'$diri/chem.mods.F
+         for stri in ` ( sed -n "/\#include/s/\#include//p" $trufile | sed 's/\"//g' ; egrep -i '^ *use ' $trufile | awk ' { print $2 } ' ) `
+         do
+            stri=`echo $stri | tr [A-Z] [a-z]`
+            if [ -f $stri ] ; then
+               echo $str1 \\
+               str1='$(LIBF)/'$diri'/'$stri
+            else
+               if [ -f $stri.F ] || [ -f $stri.F90 ] ; then
+                  str1='$(LIBO)/lib'$diri'.a('$stri'.o)'
+               else
+#                  for dirinc in dyn3d grid bibio aeronomars phymars
+                  for dirinc in $*
+                  do
+                     if [ -f ../$dirinc/$stri ] ; then
+                        echo $str1 \\
+                        str1='$(LIBF)/'`cd .. ; ls */$stri | head -1`
+                     fi
+                  done
+               fi
+            fi
+         done
+         echo $str1
+         echo '	cd $(LOCAL_DIR); \'
+	     echo '	$(COMPILE90) $(LIBF)/'$diri'/'$trufile' ; \'
+         MODU=0; egrep -i ' *module ' $trufile> /dev/null 2>&1 && MODU=1
+         if [ "$MODU" -eq '1' -a "$CRAY" != '1' ] ; then
+            if [ "$os" = 'UNIX_System_V' ] ; then
+              echo '	cp $(MOD_LOC_DIR)/*.$(MOD_SUFFIX) $(LIBO)/ ; \'
+            else
+              echo '	mv $(MOD_LOC_DIR)/'$fili'.$(MOD_SUFFIX) $(LIBO)/'$fili'.$(MOD_SUFFIX) ; \'
+            fi
+         fi
+         if [ "$XNEC" -eq '1' ] ; then
+           echo '	sxar r $(LIBO)/libsx'$diri'.a '$fili'.o ; \'
+         fi
+         echo '	$(AR) r $(LIBO)/lib'$diri'.a '$fili'.o ; $(RM) '$fili'.o ; \'
+         echo '	cd $(GCM)'
+	 echo
+      done
+#	 
+      echo
+   cd $libf
+   fi
+   fi
+done
Index: trunk/mesoscale/LMDZ.MARS/deftank_gcm
===================================================================
--- trunk/mesoscale/LMDZ.MARS/deftank_gcm	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/deftank_gcm	(revision 57)
@@ -0,0 +1,1 @@
+link in_lmdz_mars/deftank
Index: trunk/mesoscale/LMDZ.MARS/in_lmdz_mars
===================================================================
--- trunk/mesoscale/LMDZ.MARS/in_lmdz_mars	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/in_lmdz_mars	(revision 57)
@@ -0,0 +1,1 @@
+link ../LMD_MM_MARS/SIMU/in_lmdz_mars
Index: trunk/mesoscale/LMDZ.MARS/libf
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf	(revision 57)
@@ -0,0 +1,1 @@
+link libf_gcm
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/calchim.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/calchim.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/calchim.F	(revision 57)
@@ -0,0 +1,379 @@
+      subroutine calchim(ptimestep,pplay,pplev,pt,pdt,dist_sol,mu0,
+     $                   zzlay,zday,pq,pdq,dqchim,dqschim,dqcloud,
+     $                   dqscloud)
+c
+      implicit none
+c
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c  Prepare the call for the photochemical module, and send back the
+c  tendencies from photochemistry in the chemical species mass mixing ratios
+c
+c   Author:   Sebastien Lebonnois (08/11/2002)
+c   -------
+c    update 12/06/2003 for water ice clouds and compatibility with dust
+c    update 07/2003 for coupling with thermosphere (Monica Angelats-i-Coll)
+c    update 03/05/2005 cosmetic changes (Franck Lefevre)
+c
+c   Arguments:
+c   ----------
+c
+c  Input:
+c
+c    ptimestep                  timestep (s)
+c    pplay(ngridmx,nlayermx)    Pressure at the middle of the layers (Pa)
+c    pplev(ngridmx,nlayermx+1)  Intermediate pressure levels (Pa)
+c    pt(ngridmx,nlayermx)       Temperature (K)
+c    pdt(ngridmx,nlayermx)      Temperature tendency (K)
+c    dist_sol                   distance of the sun (AU)
+c    mu0(ngridmx)               cos of solar zenith angle (=1 when sun at zenith)
+c    pq(ngridmx,nlayermx,nqmx)  Advected fields, ie chemical species here
+c    pdq(ngridmx,nlayermx,nqmx) Previous tendencies on pq
+c
+c  Output:
+c
+c    dqchim(ngridmx,nlayermx,nqmx) ! tendencies on pq due to chemistry
+c    dqschim(ngridmx,nqmx)         ! tendencies on qsurf 
+c
+c=======================================================================
+
+c    Declarations :
+c    --------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "fisice.h"
+#include "conc.h"
+
+c Arguments :
+c -----------
+
+c   inputs:
+c   -------
+
+      real    ptimestep
+      real    pplay(ngridmx,nlayermx)    ! pressure at the middle of the layers
+      real    zzlay(ngridmx,nlayermx)    ! pressure at the middle of the layers
+      real    pplev(ngridmx,nlayermx+1)  ! intermediate pressure levels
+      real    pt(ngridmx,nlayermx)       ! temperature
+      real    pdt(ngridmx,nlayermx)      ! temperature tendency
+      real    dist_sol                   ! distance of the sun (AU)
+      real    mu0(ngridmx)       ! cos of solar zenith angle (=1 when sun at zenith)
+      real    pq(ngridmx,nlayermx,nqmx)  ! tracers mass mixing ratio
+      real    pdq(ngridmx,nlayermx,nqmx) ! previous tendencies
+      real    zday                       ! date (time since Ls=0, in martian days)
+
+c   outputs:
+c   --------
+
+      real dqchim(ngridmx,nlayermx,nqmx) ! tendencies on pq due to chemistry
+      real dqschim(ngridmx,nqmx)         ! tendencies on qsurf 
+      real dqcloud(ngridmx,nlayermx,nqmx)! tendencies on pq due to condensation
+      real dqscloud(ngridmx,nqmx)        ! tendencies on qsurf 
+
+c Local variables :
+c -----------------
+
+      character*5 str5
+      integer  ig,l,iq, i_co2, i_o
+      integer  foundswitch, lswitch
+      real zq(ngridmx,nlayermx,nqmx) ! pq+pdq*ptimestep before chemistry
+                                     ! new mole fraction after
+      real colden(ngridmx,nqmx)      ! Column densities (cm-2)
+      real zt(ngridmx,nlayermx)      ! temperature
+c
+c  for each column of atmosphere:
+c
+      real zpress(nlayermx)       !  Pressure (mbar)
+      real zdens(nlayermx)        !  Density  (cm-3)
+      real ztemp(nlayermx)        !  Temperature (K)
+      real zlocal(nlayermx)       !  Altitude (km)
+      real zycol(nlayermx,nqmx)   !  Composition (mole fractions)
+      real szacol                 !  Solar zenith angle
+      real jo3(nlayermx)          !  Photodissociation rate O3->O1D (s-1)
+c
+c for output:
+c
+      real zdens3d(ngridmx,nlayermx) !  Density  (cm-3)
+      real jo3_3d(ngridmx,nlayermx)  !  Photodissociation rate O3->O1D (s-1)
+      real surfice(ngridmx,nlayermx) !  Surface of ice particules (um2/cm3)
+      logical output
+
+      logical firstcall
+      data    firstcall/.true./
+      save    firstcall
+c
+c  scheme A: 1 ; scheme B: 2
+c
+      integer scheme
+      data  scheme/2/
+c
+c=======================================================================
+c     initialization of the chemistry (first call only)
+c=======================================================================
+c
+      if (firstcall) then
+c
+         if (photochem) then
+            print*,'INIT CHEMISTRY'
+            if (scheme  .eq.  1) then
+               print*,'Scheme A : A METTRE A JOUR !!'
+               stop
+c              call init_chimie_A
+            else
+               print*,'Scheme B'
+               call init_chimie_B
+            end if
+         end if
+         firstcall = .false.
+      end if
+c
+c=======================================================================
+c     loop over grid
+c=======================================================================
+c
+      do ig = 1,ngridmx
+c
+c     local updates
+c 
+         foundswitch = 0
+         do l = 1,nlayermx
+            do iq = nqchem_min,nqmx
+               zq(ig,l,iq) = pq(ig,l,iq) + pdq(ig,l,iq)*ptimestep
+               zt(ig,l)    = pt(ig,l)    + pdt(ig,l)   *ptimestep
+               zycol(l,iq) = zq(ig,l,iq) * mmean(ig,l)/mmol(iq)
+            enddo
+            zpress(l) = pplay(ig,l)/100.
+            ztemp(l)  = zt(ig,l)
+            zdens(l)  = zpress(l)/(kb*1.e4*ztemp(l))
+            zlocal(l) = zzlay(ig,l)/1000.
+c
+c     search for switch index between regions
+c
+            if (photochem .and. thermochem) then
+               if (foundswitch .eq. 0 .and. pplay(ig,l).lt.1.e-3) then
+                  lswitch = l
+                  foundswitch=1
+               end if
+            end if
+            if ( .not. photochem) then
+               lswitch = 22
+            end if
+            if (.not.  thermochem) then
+               lswitch = min(33,nlayermx+1)
+            end if
+c
+c     ice surface area  in microns^2/cm^3
+c
+c     = 4 pi r^2 * [ zq * mugaz/NA / (rhoice*4/3 pi r^3) ] *zdens
+c     = 3/r * [ zq * mugaz/NA / rhoice ] *zdens
+c     with r in microns, rhoice = 0.92e-12 g microns^-3 and zdens in cm^-3
+c
+            if (iceparty) then
+               zycol(l,nqmx-1) = (3.e-6/rice(ig,l))*zq(ig,l,nqmx-1)
+     $                           *(mugaz/6.022e23)*zdens(l)/0.92e-12
+c              write(*,*) "rice=",rice(ig,l)," m / zdens=",zdens(l),
+c    $        " cm-3 / icesurf=",zycol(l,nqmx-1)," microns^2/cm^3"
+               surfice(ig,l) = zycol(l,nqmx-1)
+            end if
+c
+         end do
+c
+         szacol = acos(mu0(ig))*180./pi
+c
+c=======================================================================
+c     call chemical subroutine
+c=======================================================================
+c
+        if (photochem) then
+           if (scheme .eq. 1) then
+              print*,'Scheme A : A METTRE A JOUR !!'
+c             call photochemist_A(zycol,szacol,ptimestep,
+c    $                            zpress,ztemp,zdens,dist_sol)
+           else
+              call photochemist_B(lswitch,zycol,szacol,ptimestep,
+     $                            zpress,ztemp,zdens,dist_sol,jo3)
+           end if
+        end if
+        if (thermochem) then
+           call chemthermos(ig,lswitch,zycol,ztemp,zdens,zpress,
+     $                      zlocal,szacol,ptimestep,zday)
+        end if
+c
+c=======================================================================
+c     tendencies
+c=======================================================================
+c
+c     must be 0. for water ice:
+c
+         if (iceparty) then
+            do l = 1,nlayermx
+               dqchim(ig,l,nqmx-1) = 0.
+            end do
+         end if
+c
+c     tendency for CO2 = - sum of others for lower atmosphere
+c     tendency for O   = - sum of others for upper atmosphere
+c
+         do l = 1,nlayermx
+            if (l .lt. lswitch) then
+               do iq = nqchem_min,nqmx
+                  if ((noms(iq) .ne. "co2") .and. 
+     $                (noms(iq) .ne. "ice")) then
+                     dqchim(ig,l,iq) = (zycol(l,iq)*mmol(iq)/mmean(ig,l)
+     $                                - zq(ig,l,iq))/ptimestep
+                  else if (noms(iq) .eq. "co2") then
+                     i_co2 = iq
+                     dqchim(ig,l,iq) = 0.
+                  end if
+                  dqschim(ig,iq) = 0.
+               end do
+               do iq = nqchem_min,nqmx
+                  if (noms(iq) .ne. "co2") then
+                     dqchim(ig,l,i_co2) = dqchim(ig,l,i_co2) 
+     $                                  - dqchim(ig,l,iq)
+                  end if
+                end do
+             else if (l .ge. lswitch) then
+                do iq = nqchem_min,nqmx
+                   if ((noms(iq).ne."o") .and.(noms(iq) .ne."ice")) then
+                      dqchim(ig,l,iq) = (zycol(l,iq)*mmol(iq)
+     $                                  /mmean(ig,l)
+     $                                 - zq(ig,l,iq))/ptimestep
+                   else if (noms(iq) .eq. "o") then
+                      i_o = iq
+                      dqchim(ig,l,iq) = 0.
+                   end if
+                enddo
+                do iq = nqchem_min,nqmx
+                   if (noms(iq) .ne. "o") then
+                      dqchim(ig,l,i_o) = dqchim(ig,l,i_o) 
+     $                                 - dqchim(ig,l,iq)
+                   end if
+                end do
+             end if
+          end do
+c
+c     dust
+c
+          if (nqchem_min .gt. 1) then
+             do iq = 1,nqchem_min-1
+                do l = 1,nlayermx
+                   dqchim(ig,l,iq) = 0.
+                end do
+                dqschim(ig,iq) = 0.
+             end do
+          end if
+c
+c     condensation of h2o2
+c
+          call perosat(ig,ptimestep,pplev,pplay,
+     $                 ztemp,zycol,dqcloud,dqscloud)
+c
+c     for outputs
+c
+          do iq = nqchem_min,nqmx
+             colden(ig,iq) = 0.
+             do l = 1,nlayermx
+c
+c     column density converted in cm-2
+c     pplev en pa, mugaz en g.mol-1 et g en m.s-2
+c     not for ice
+c
+                if (noms(iq) .ne. "h2o2") then
+                  colden(ig,iq) = colden(ig,iq) + zycol(l,iq)
+     $                         *6.022e22*(pplev(ig,l)-pplev(ig,l+1))
+     $                         /(mmean(ig,l)*g)
+                else   ! for H2O2, remove condensation from zycol
+                  colden(ig,iq) = colden(ig,iq) + (zycol(l,iq) +
+     $               dqcloud(ig,l,iq)*ptimestep*mmean(ig,l)/mmol(iq))
+     $                         *6.022e22*(pplev(ig,l)-pplev(ig,l+1))
+     $                         /(mmean(ig,l)*g)
+                end if
+c
+c     local densities, for outputs (put in zq)
+c     not for ice
+c
+                zq(ig,l,iq) = zycol(l,iq)*zdens(l)
+c                        for H2O2, remove condensation from zycol
+                if (noms(iq) .eq. "h2o2") then
+                   zq(ig,l,iq) = zdens(l)*(zycol(l,iq) +
+     $               dqcloud(ig,l,iq)*ptimestep*mmean(ig,l)/mmol(iq))
+                end if
+             end do
+          end do
+c
+c     density and j(o3->o1d), for outputs
+c
+          zdens3d(ig,1) = zdens(1)
+          jo3_3d(ig,1) = jo3(1)
+          do l = 2,nlayermx
+             zdens3d(ig,l) = zdens(l)
+             jo3_3d(ig,l) = jo3(l)
+          end do
+c
+c=======================================================================
+c     end of loop over grid
+c=======================================================================
+c
+      end do
+c
+c=======================================================================
+c     write outputs
+c=======================================================================
+c
+      output = .true.
+
+      if (output) then
+         if (ngridmx .gt. 1) then
+c           call writediagfi(ngridmx,'dens','atm dens.','cm-3',3,zdens3d(1,1))
+c           call writediagfi(ngridmx,'jo3','j o3->o1d','s-1',3,jo3_3d(1,1))
+c           call writediagfi(ngridmx,'sice','ice surf.','um2/cm3',3,surfice(1,1))
+            do iq = nqchem_min,nqmx
+               if (noms(iq) .ne. "ice") then
+                  write(str5(1:5),'(a5)') noms(iq)
+                  call writediagfi(ngridmx,'n_'//str5,'density',
+     $                             'cm-3',3,zq(1,1,iq))
+c                 call writediagfi(ngridmx,'dqch_'//str5,'density','cm-3',3,dqchim(1,1,iq))
+c                 if (noms(iq) .eq. "h2o2" .or. noms(iq) .eq. "h2o") then
+c                    call writediagfi(ngridmx,'cl_'//str5,'density','cm-3',3,dqcloud(1,1,iq))
+c                 end if
+                  call writediagfi(ngridmx,'c_'//str5,'col. dens.',
+     $                             'cm-2',2,colden(1,iq))
+               end if
+            end do
+c
+            if (callstats) then
+c
+c              convert to mole.cm-2 for the column densities
+c
+               do iq = nqchem_min,nqmx
+                  do ig = 1,ngridmx
+                     colden(ig,iq) = colden(ig,iq)/6.022e23
+                  end do   
+               end do 
+c
+c              call wstats(ngridmx,"jo3","jo3->o1d","s-1",3,jo3_3d)
+c
+               do iq = nqchem_min,nqmx
+                  if (noms(iq) .ne. "ice") then
+                     write(str5(1:5),'(a5)') noms(iq)
+                     call wstats(ngridmx,"n_"//str5,"density",
+     &                           "cm-3",3,zq(1,1,iq))
+                     call wstats(ngridmx,"c_"//str5,"col. dens.",
+     &                           "mol cm-2",2,colden(1,iq))
+                  end if
+               end do
+            end if
+         end if
+c
+      endif
+c
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/ch.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/ch.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/ch.F	(revision 57)
@@ -0,0 +1,550 @@
+c 	************************************************************
+c
+c		chapman function for grazing incidence
+c
+c 	************************************************************
+
+	function ch(x,z) 
+
+	integer ierr
+	real ch,x
+
+	double precision ch1,sublim,z,error,aerr,rerr
+	double precision dcadre,fch
+	external fch,dcadre 
+
+	common/integ/ax,az
+	double precision ax,az 
+
+c
+
+	ax=x
+	az=z
+
+	aerr= 0.0d0
+	rerr= 0.0001d0 
+	sublim = 1.0d-4
+	ch1 = dcadre( fch, sublim, az, aerr, rerr, error, ierr )
+	ch = ax * sin(az) * ch1
+
+	return
+	end
+
+c 	************************************************************
+c
+c		integrand for the chapman function 
+c
+c 	************************************************************
+
+	double precision function fch(gi)
+
+	double precision gi
+
+	common/integ/x,z
+	double precision x,z 
+
+!	real x,z,a
+
+	fch = (1./sin(gi))**2. * exp( x *(1.- sin(z)/sin(gi)) )
+
+	return 
+	end
+
+
+
+
+******************************************************************************
+
+      double precision function dcadre (f,a,b,aerr,rerr,error,ier)              
+c                                  specifications for arguments                 
+      integer            ier                                                    
+      double precision   f,a,b,aerr,rerr,error                                  
+c                                  specifications for local variables           
+      integer            ibegs(30),maxts,maxtbl,mxstge,ibeg,ii,nnleft           
+      integer            i,n2,iii,istep2,iend,istep,l,lm1,it,istage,n           
+      double precision   t(10,10),r(10),ait(10),dif(10),rn(4),ts(2049)          
+      double precision   begin(30),finis(30),est(30)                            
+      double precision   h2tol,aittol,length,jumptl,zero,p1,half,one            
+      double precision   two,four,fourp5,ten,hun,cadre,aitlow                   
+      double precision   stepmn,stepnm,stage,curest,fnsize,hrerr                
+      double precision   prever,beg,fbeg,edn,fend,step,astep,tabs,hovn          
+      double precision   fn,sum,sumabs,vint,tabtlm,ergl,ergoal                  
+      double precision   erra,errr,fextrp,errer,diff,sing,fextm1                
+      double precision   h2next,singnx,slope,fbeg2,erret,h2tfex,fi              
+      logical            h2conv,aitken,right,reglar,reglsv(30)                  
+      data               aitlow,h2tol,aittol,jumptl,maxts,maxtbl,mxstge         
+     1                   /1.1d0,.15d0,.1d0,.01d0,2049,10,30/                    
+      data               rn(1),rn(2),rn(3),rn(4)/                               
+     1                   .7142005d0,.3466282d0,.843751d0,.1263305d0/            
+      data               zero,p1,half,one,two,four,fourp5,ten,hun               
+     1                   /0.0d0,0.1d0,0.5d0,1.0d0,2.0d0,4.0d0,                  
+     2                   4.5d0,10.0d0,100.0d0/                                  
+c                                  first executable statement                   
+      ier = 0                                                                   
+      cadre = zero                                                              
+      error = zero                                                              
+      curest = zero                                                             
+      vint = zero                                                               
+      length = dabs(b-a)
+
+      if (length .eq. zero) go to 215                                           
+      if (rerr .gt. p1 .or. rerr .lt. zero) go to 210                           
+      hrerr = rerr+hun                                                          
+      if (aerr .eq. zero .and. hrerr .le. hun) go to 210                        
+      errr = rerr                                                               
+      erra = dabs(aerr)                                                         
+      stepmn = length/(two**mxstge)                                             
+      stepnm = dmax1(length,dabs(a),dabs(b))*ten                                
+      stage = half                                                              
+      istage = 1                                                                
+      fnsize = zero                                                             
+      prever = zero                                                             
+      reglar = .false.                                                          
+c                                  the given interval of integration            
+c                                    is the first interval considered.          
+      beg = a                                                                   
+      fbeg = f(beg)*half                                                        
+      ts(1) = fbeg                                                              
+      ibeg = 1                                                                  
+      edn = b                                                                   
+      fend = f(edn)*half                                                        
+      ts(2) = fend                                                              
+      iend = 2                                                                  
+    5 right = .false.                                                           
+c                                  investigation of a particular                
+c                                    subinterval begins at this point.          
+   10 step = edn - beg                                                          
+      astep =  dabs(step)                                                       
+      if (astep .lt. stepmn) go to 205                                          
+      hrerr = stepnm+astep                                                      
+      if (hrerr .eq. stepnm) go to 205                                          
+      t(1,1) = fbeg + fend                                                      
+      tabs = dabs(fbeg) + dabs(fend)                                            
+      l = 1                                                                     
+      n = 1                                                                     
+      h2conv = .false.                                                          
+      aitken = .false.                                                          
+   15 lm1 = l                                                                   
+      l = l + 1                                                                 
+c                                  calculate the next trapezoid sum,            
+c                                    t(l,1), which is based on *n2* + 1         
+c                                    equispaced points. here,                   
+c                                    n2 = n*2 = 2**(l-1).                       
+      n2 = n+n                                                                  
+      fn = n2                                                                   
+      istep = (iend - ibeg)/n                                                   
+      if (istep .gt. 1) go to 25                                                
+      ii = iend                                                                 
+      iend = iend + n                                                           
+      if (iend .gt. maxts) go to 200                                            
+      hovn = step/fn                                                            
+      iii = iend                                                                
+      fi = one                                                                  
+      do 20 i=1,n2,2                                                            
+         ts(iii) = ts(ii)                                                       
+         ts(iii-1) = f(edn - fi * hovn)                                         
+         fi = fi+two                                                            
+         iii = iii-2                                                            
+         ii = ii-1                                                              
+   20 continue                                                                  
+      istep = 2                                                                 
+   25 istep2 = ibeg + istep/2                                                   
+      sum = zero                                                                
+      sumabs = zero                                                             
+      do 30 i=istep2,iend,istep                                                 
+         sum = sum + ts(i)                                                      
+         sumabs = sumabs + dabs(ts(i))                                          
+   30 continue                                                                  
+      t(l,1) = t(l-1,1)*half+sum/fn                                             
+      tabs = tabs*half+sumabs/fn                                                
+      n = n2                                                                    
+c                                  get preliminary value for *vint*             
+c                                    from last trapezoid sum and update         
+c                                    the error requirement *ergoal*             
+c                                    for this subinterval.                      
+      it = 1                                                                    
+      vint = step*t(l,1)                                                        
+      tabtlm = tabs*ten                                                         
+      fnsize = dmax1(fnsize,dabs(t(l,1)))                                       
+      ergl = astep*fnsize*ten                                                   
+      ergoal = stage*dmax1(erra,errr*dabs(curest+vint))                         
+c                                  complete row l and column l of *t*           
+c                                    array.                                     
+      fextrp = one                                                              
+      do 35 i=1,lm1                                                             
+         fextrp = fextrp*four                                                   
+         t(i,l) = t(l,i) - t(l-1,i)                                             
+         t(l,i+1) = t(l,i) + t(i,l)/(fextrp-one)                                
+   35 continue                                                                  
+      errer = astep*dabs(t(1,l))                                                
+c                                  preliminary decision procedure               
+c                                    if l = 2 and t(2,1) = t(1,1),              
+c                                    go to 135 to follow up the                 
+c                                    impression that intergrand is              
+c                                    straight line.                             
+      if (l .gt. 2) go to 40                                                    
+      hrerr = tabs+p1*dabs(t(1,2))                                              
+      if (hrerr .eq. tabs) go to 135                                            
+      go to 15                                                                  
+c                                  caculate next ratios for                     
+c                                    columns 1,...,l-2 of t-table               
+c                                    ratio is set to zero if difference         
+c                                    in last two entries of column is           
+c                                    about zero                                 
+   40 do 45 i=2,lm1                                                             
+         diff = zero                                                            
+         hrerr = tabtlm+dabs(t(i-1,l))                                          
+         if (hrerr .ne. tabtlm) diff = t(i-1,lm1)/t(i-1,l)                      
+         t(i-1,lm1) = diff                                                      
+   45 continue                                                                  
+      if (dabs(four-t(1,lm1)) .le. h2tol) go to 60                              
+      if (t(1,lm1) .eq. zero) go to 55                                          
+      if (dabs(two-dabs(t(1,lm1))) .lt. jumptl) go to 130                       
+      if (l .eq. 3) go to 15                                                    
+      h2conv = .false.                                                          
+      if (dabs((t(1,lm1)-t(1,l-2))/t(1,lm1)) .le. aittol) go to 75              
+   50 if (reglar) go to 55                                                      
+      if (l .eq. 4) go to 15                                                    
+      hrerr = ergl+errer                                                        
+   55 if (errer .gt. ergoal .and. hrerr .ne. ergl) go to 175                    
+      go to 145                                                                 
+c                                  cautious romberg extrapolation               
+   60 if (h2conv) go to 65                                                      
+      aitken = .false.                                                          
+      h2conv = .true.                                                           
+   65 fextrp = four                                                             
+   70 it = it + 1                                                               
+      vint = step*t(l,it)                                                       
+      errer = dabs(step/(fextrp-one)*t(it-1,l))                                 
+      if (errer .le. ergoal) go to 160                                          
+      hrerr = ergl+errer                                                        
+      if (hrerr .eq. ergl) go to 160                                            
+      if (it .eq. lm1) go to 125                                                
+      if (t(it,lm1) .eq. zero) go to 70                                         
+      if (t(it,lm1) .le. fextrp) go to 125                                      
+      if (dabs(t(it,lm1)/four-fextrp)/fextrp .lt. aittol)                       
+     1       fextrp = fextrp*four                                               
+      go to 70                                                                  
+c                                  integrand may have x**alpha type             
+c                                    singularity                                
+c                                    resulting in a ratio of *sing*  =          
+c                                    2**(alpha + 1)                             
+   75 if (t(1,lm1) .lt. aitlow) go to 175                                       
+      if (aitken) go to 80                                                      
+      h2conv = .false.                                                          
+      aitken = .true.                                                           
+   80 fextrp = t(l-2,lm1)                                                       
+      if (fextrp .gt. fourp5) go to 65                                          
+      if (fextrp .lt. aitlow) go to 175                                         
+      if (dabs(fextrp-t(l-3,lm1))/t(1,lm1) .gt. h2tol) go to 175                
+      sing = fextrp                                                             
+      fextm1 = one/(fextrp - one)                                               
+      ait(1) = zero                                                             
+      do 85 i=2,l                                                               
+         ait(i) = t(i,1) + (t(i,1)-t(i-1,1))*fextm1                             
+         r(i) = t(1,i-1)                                                        
+         dif(i) = ait(i) - ait(i-1)                                             
+   85 continue                                                                  
+      it = 2                                                                    
+   90 vint = step*ait(l)                                                        
+      errer = errer*fextm1                                                      
+      hrerr = ergl+errer                                                        
+      if (errer .gt. ergoal .and. hrerr .ne. ergl) go to 95                     
+      ier = max0(ier,65)                                                        
+      go to 160                                                                 
+   95 it = it + 1                                                               
+      if (it .eq. lm1) go to 125                                                
+      if (it .gt. 3) go to 100                                                  
+      h2next = four                                                             
+      singnx = sing+sing                                                        
+  100 if (h2next .lt. singnx) go to 105                                         
+      fextrp = singnx                                                           
+      singnx = singnx+singnx                                                    
+      go to 110                                                                 
+  105 fextrp = h2next                                                           
+      h2next = four*h2next                                                      
+  110 do 115 i=it,lm1                                                           
+         r(i+1) = zero                                                          
+         hrerr = tabtlm+dabs(dif(i+1))                                          
+         if (hrerr .ne. tabtlm) r(i+1) = dif(i)/dif(i+1)                        
+  115 continue                                                                  
+      h2tfex = -h2tol*fextrp                                                    
+      if (r(l) - fextrp .lt. h2tfex) go to 125                                  
+      if (r(l-1)-fextrp .lt. h2tfex) go to 125                                  
+      errer = astep*dabs(dif(l))                                                
+      fextm1 = one/(fextrp - one)                                               
+      do 120 i=it,l                                                             
+         ait(i) = ait(i) + dif(i)*fextm1                                        
+         dif(i) = ait(i) - ait(i-1)                                             
+  120 continue                                                                  
+      go to 90                                                                  
+c                                  current trapezoid sum and resulting          
+c                                    extrapolated values did not give           
+c                                    a small enough *errer*.                    
+c                                    note -- having prever .lt. errer           
+c                                    is an almost certain sign of               
+c                                    beginning trouble with in the func-        
+c                                    tion values. hence, a watch for,           
+c                                    and control of, noise should               
+c                                    begin here.                                
+  125 fextrp = dmax1(prever/errer,aitlow)                                       
+      prever = errer                                                            
+      if (l .lt. 5) go to 15                                                    
+      if (l-it .gt. 2 .and. istage .lt. mxstge) go to 170                       
+      erret = errer/(fextrp**(maxtbl-l))                                        
+      hrerr = ergl+erret                                                        
+      if (erret .gt. ergoal .and. hrerr .ne. ergl) go to 170                    
+      go to 15                                                                  
+c                                  integrand has jump (see notes)               
+  130 hrerr = ergl+errer                                                        
+      if (errer .gt. ergoal .and. hrerr .ne. ergl) go to 170                    
+c                                  note that  2*fn = 2**l                       
+      diff = dabs(t(1,l))*(fn+fn)                                               
+      go to 160                                                                 
+c                                  integrand is straight line                   
+c                                    test this assumption by comparing          
+c                                    the value of the integrand at              
+c                                    four *randomly chosen* points with         
+c                                    the value of the straight line             
+c                                    interpolating the integrand at the         
+c                                    two end points of the sub-interval.        
+c                                    if test is passed, accept *vint*           
+  135 slope = (fend-fbeg)*two                                                   
+      fbeg2 = fbeg+fbeg                                                         
+      do 140 i=1,4                                                              
+         diff = dabs(f(beg+rn(i)*step) - fbeg2-rn(i)*slope)                     
+         hrerr = tabtlm+diff                                                    
+         if(hrerr .ne. tabtlm) go to 155                                        
+  140 continue                                                                  
+      go to 160                                                                 
+c                                  noise may be dominant feature                
+c                                    estimate noise level by comparing          
+c                                    the value of the integrand at              
+c                                    four *randomly chosen* points with         
+c                                    the value of the straight line             
+c                                    interpolating the integrand at the         
+c                                    two endpoints. if small enough,            
+c                                    accept *vint*                              
+  145 slope = (fend-fbeg)*two                                                   
+      fbeg2 = fbeg+fbeg                                                         
+      i = 1                                                                     
+  150 diff = dabs(f(beg+rn(i)*step) - fbeg2-rn(i)*slope)                        
+  155 errer = dmax1(errer,astep*diff)                                           
+      hrerr = ergl+errer                                                        
+      if (errer .gt. ergoal .and. hrerr .ne. ergl) go to 175                    
+      i = i+1                                                                   
+      if (i .le. 4) go to 150                                                   
+      ier = 66                                                                  
+c                                  intergration over current sub-               
+c                                    interval successful                        
+c                                    add *vint* to *dcadre* and *errer*         
+c                                    to *error*, then set up next sub-          
+c                                    interval, if any.                          
+  160 cadre = cadre + vint                                                      
+      error = error + errer                                                     
+      if (right) go to 165                                                      
+      istage = istage - 1                                                       
+      if (istage .eq. 0) go to 220                                              
+      reglar = reglsv(istage)                                                   
+      beg = begin(istage)                                                       
+      edn = finis(istage)                                                       
+      curest = curest - est(istage+1) + vint                                    
+      iend = ibeg - 1                                                           
+      fend = ts(iend)                                                           
+      ibeg = ibegs(istage)                                                      
+      go to 180                                                                 
+  165 curest = curest + vint                                                    
+      stage = stage+stage                                                       
+      iend = ibeg                                                               
+      ibeg = ibegs(istage)                                                      
+      edn = beg                                                                 
+      beg = begin(istage)                                                       
+      fend = fbeg                                                               
+      fbeg = ts(ibeg)                                                           
+      go to 5                                                                   
+c                                  integration over current subinterval         
+c                                    is unsuccessful. mark subinterval          
+c                                    for further subdivision. set up            
+c                                    next subinterval.                          
+  170 reglar = .true.                                                           
+  175 if (istage .eq. mxstge) go to 205                                         
+      if (right) go to 185                                                      
+      reglsv(istage+1) = reglar                                                 
+      begin(istage) = beg                                                       
+      ibegs(istage) = ibeg                                                      
+      stage = stage*half                                                        
+  180 right = .true.                                                            
+      beg = (beg+edn)*half                                                      
+      ibeg = (ibeg+iend)/2                                                      
+      ts(ibeg) = ts(ibeg)*half                                                  
+      fbeg = ts(ibeg)                                                           
+      go to 10                                                                  
+  185 nnleft = ibeg - ibegs(istage)                                             
+      if (iend+nnleft .ge. maxts) go to 200                                     
+      iii = ibegs(istage)                                                       
+      ii = iend                                                                 
+      do 190 i=iii,ibeg                                                         
+         ii = ii + 1                                                            
+         ts(ii) = ts(i)                                                         
+  190 continue                                                                  
+      do 195 i=ibeg,ii                                                          
+         ts(iii) = ts(i)                                                        
+         iii = iii + 1                                                          
+  195 continue                                                                  
+      iend = iend + 1                                                           
+      ibeg = iend - nnleft                                                      
+      fend = fbeg                                                               
+      fbeg = ts(ibeg)                                                           
+      finis(istage) = edn                                                       
+      edn = beg                                                                 
+      beg = begin(istage)                                                       
+      begin(istage) = edn                                                       
+      reglsv(istage) = reglar                                                   
+      istage = istage + 1                                                       
+      reglar = reglsv(istage)                                                   
+      est(istage) = vint                                                        
+      curest = curest + est(istage)                                             
+      go to 5                                                                   
+c                                  failure to handle given integra-             
+c                                    tion problem                               
+  200 ier = 131                                                                 
+      go to 215                                                                 
+  205 ier = 132                                                                 
+      go to 215                                                                 
+  210 ier = 133                                                                 
+  215 cadre = curest + vint                                                     
+  220 dcadre = cadre                                                            
+ 9000 continue                                                                  
+      if (ier .ne. 0) call uertst (ier,6hdcadre)                                
+ 9005 return                                                                    
+      end     
+
+
+******************************************************************************
+
+	subroutine uertst (ier,name)                                              
+c                                  specifications for arguments                 
+      integer            ier                                                    
+      integer            name(2)                                                
+c                                  specifications for local variables           
+      integer            i,ieq,ieqdf,iounit,level,levold,nameq(6),              
+     *                   namset(6),namupk(6),nin,nmtb                           
+      data               namset/1hu,1he,1hr,1hs,1he,1ht/                        
+      data               nameq/6*1h /                                           
+      data               level/4/,ieqdf/0/,ieq/1h=/                             
+c                                  unpack name into namupk                      
+c                                  first executable statement                   
+      call uspkd (name,6,namupk,nmtb)                                           
+c                                  get output unit number                       
+      call ugetio(1,nin,iounit)                                                 
+c                                  check ier                                    
+      if (ier.gt.999) go to 25                                                  
+      if (ier.lt.-32) go to 55                                                  
+      if (ier.le.128) go to 5                                                   
+      if (level.lt.1) go to 30                                                  
+c                                  print terminal message                       
+      if (ieqdf.eq.1) write(iounit,35) ier,nameq,ieq,namupk                     
+      if (ieqdf.eq.0) write(iounit,35) ier,namupk                               
+      go to 30                                                                  
+    5 if (ier.le.64) go to 10                                                   
+      if (level.lt.2) go to 30                                                  
+c                                  print warning with fix message               
+c      if (ieqdf.eq.1) write(iounit,40) ier,nameq,ieq,namupk                     
+c      if (ieqdf.eq.0) write(iounit,40) ier,namupk                               
+      if (ieqdf.eq.1) continue 
+      if (ieqdf.eq.0) continue 
+      go to 30                                                                  
+   10 if (ier.le.32) go to 15                                                   
+c                                  print warning message                        
+      if (level.lt.3) go to 30                                                  
+      if (ieqdf.eq.1) write(iounit,45) ier,nameq,ieq,namupk                     
+      if (ieqdf.eq.0) write(iounit,45) ier,namupk                               
+      go to 30                                                                  
+   15 continue                                                                  
+c                                  check for uerset call                        
+      do 20 i=1,6                                                               
+         if (namupk(i).ne.namset(i)) go to 25                                   
+   20 continue                                                                  
+      levold = level                                                            
+      level = ier                                                               
+      ier = levold                                                              
+      if (level.lt.0) level = 4                                                 
+      if (level.gt.4) level = 4                                                 
+      go to 30                                                                  
+   25 continue                                                                  
+      if (level.lt.4) go to 30                                                  
+c                                  print non-defined message                    
+      if (ieqdf.eq.1) write(iounit,50) ier,nameq,ieq,namupk                     
+      if (ieqdf.eq.0) write(iounit,50) ier,namupk                               
+   30 ieqdf = 0                                                                 
+      return                                                                    
+   35 format(19h *** terminal error,10x,7h(ier = ,i3,                           
+     1       20h) from imsl routine ,6a1,a1,6a1)                                
+   40 format(27h *** warning with fix error,2x,7h(ier = ,i3,                    
+     1       20h) from imsl routine ,6a1,a1,6a1)                                
+   45 format(18h *** warning error,11x,7h(ier = ,i3,                            
+     1       20h) from imsl routine ,6a1,a1,6a1)                                
+   50 format(20h *** undefined error,9x,7h(ier = ,i5,                           
+     1       20h) from imsl routine ,6a1,a1,6a1)                                
+c                                                                               
+c                                  save p for p = r case                        
+c                                    p is the page namupk                       
+c                                    r is the routine namupk                    
+   55 ieqdf = 1                                                                 
+      do 60 i=1,6                                                               
+   60 nameq(i) = namupk(i)                                                      
+   65 return                                                                    
+      end                          
+
+
+************************************************************************
+
+      subroutine uspkd  (packed,nchars,unpakd,nchmtb)                           
+c                                  specifications for arguments                 
+      integer            nc,nchars,nchmtb                                       
+c                                                                               
+c      integer            unpakd(1),iblank                                       
+      integer            unpakd(nchars),iblank                                       
+      character          packed(1)           ! Modificado el 29-Ago-2001 porque
+!      integer            packed(1)            esto deberia ser CHARACTER, no??
+      data               iblank /1h /                                           
+c                                  initialize nchmtb                            
+      nchmtb = 0                                                                
+c                                  return if nchars is le zero                  
+      if(nchars.le.0) return                                                    
+c                                  set nc=number of chars to be decoded         
+      nc = min0 (129,nchars)                                                   
+!      decode (nc,150,packed) (unpakd(i),i=1,nc)                                
+      read (packed,150) (unpakd(i),i=1,nc)                                
+  150 format (129a1)                                                           
+c                                  check unpakd array and set nchmtb            
+c                                  based on trailing blanks found               
+      do 200 n = 1,nc                                                           
+         nn = nc - n + 1                                                        
+         if(unpakd(nn) .ne. 536870912) go to 210                                
+  200 continue                                                                  
+  210 nchmtb = nn                                                               
+      return                                                                    
+      end            
+
+
+****************************************************************************
+
+      subroutine ugetio(iopt,nin,nout)                                          
+c                                  specifications for arguments                 
+      integer            iopt,nin,nout                                          
+c                                  specifications for local variables           
+      integer            nind,noutd                                             
+      data               nind/5/,noutd/6/                                       
+c                                  first executable statement                   
+      if (iopt.eq.3) go to 10                                                   
+      if (iopt.eq.2) go to 5                                                    
+      if (iopt.ne.1) go to 9005                                                 
+      nin = nind                                                                
+      nout = noutd                                                              
+      go to 9005                                                                
+    5 nind = nin                                                                
+      go to 9005                                                                
+   10 noutd = nout                                                              
+ 9005 return                                                                    
+      end       
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chemthermos.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chemthermos.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chemthermos.F	(revision 57)
@@ -0,0 +1,151 @@
+      SUBROUTINE chemthermos(ig,lswitch,zycol,ztemp,zdens,zpress,
+     $                       zlocal,zenit,ptimestep,zday)
+
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing chemical variations in the thermosphere
+c
+c   author:  MAC July 2003
+c   ------
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "param.h"
+#include "param_v3.h"
+#include "chimiedata.h"
+#include "conc.h"
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER lswitch,ig
+
+      REAL zday,zycol(nlayermx,nqmx)
+      REAL ptimestep
+      real zenit
+      real ztemp(nlayermx)
+      real zdens(nlayermx)
+      real zpress(nlayermx)			! in mbar
+c
+c    Local variables :
+c    -----------------
+      INTEGER nlayer,l,nesptherm
+      parameter (nesptherm = 11)
+      real tmean
+      real aux1(nlayermx),aux2(nlayermx)
+      real zlocal(nlayermx)
+      real rm(nlayermx,nesptherm) 		!number density (cm-3)
+
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2, 
+     $        i_o1d, i_o, i_h, i_oh, i_ho2
+      integer g_co2, g_co, g_o2, g_h2, g_h2o, g_h2o2, 
+     $        g_o1d, g_o, g_h, g_oh, g_ho2, g_o3, g_n2
+
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+
+c      if (firstcall) then
+c        call param_read
+c        firstcall= .false.
+c      endif
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      g_co2      =  nqchem_min
+      g_co       =  nqchem_min + 1
+      g_o        =  nqchem_min + 2
+      g_o1d      =  nqchem_min + 3
+      g_o2       =  nqchem_min + 4
+      g_o3       =  nqchem_min + 5
+      g_h        =  nqchem_min + 6
+      g_h2       =  nqchem_min + 7
+      g_oh       =  nqchem_min + 8
+      g_ho2      =  nqchem_min + 9
+      g_h2o2     =  nqchem_min + 10
+      g_n2       =  nqchem_min + 11
+      g_h2o      =  nqmx
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the thermospheric chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2  = 1
+      i_o2   = 2
+      i_o    = 3
+      i_co   = 4
+      i_h    = 5
+      i_oh   = 6
+      i_ho2  = 7
+      i_h2   = 8
+      i_h2o  = 9
+      i_h2o2 = 10
+      i_o1d  = 11
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      nlayer=nlayermx
+c      zlocal(1)=0.00625
+c      do l=2,nlayer
+c        tmean=ztemp(l)
+c        if(ztemp(l).ne.ztemp(l-1))
+c     &    tmean=(ztemp(l)-ztemp(l-1))/log(ztemp(l)/ztemp(l-1))
+c        zlocal(l)= zlocal(l-1)-log(zpress(l)/zpress(l-1))
+c     &                         *Rnew(ig,l-1)*tmean/g/1000.
+c      enddo
+
+      do l=1,nlayer
+        aux1(l)=0.
+        aux2(l)=0.
+        rm(l,i_co2)  = zycol(l,g_co2)  *zdens(l)  
+        rm(l,i_co)   = zycol(l,g_co)   *zdens(l) 
+        rm(l,i_o)    = zycol(l,g_o)    *zdens(l)
+        rm(l,i_o1d)  = zycol(l,g_o1d)  *zdens(l) 
+        rm(l,i_o2)   = zycol(l,g_o2)   *zdens(l)
+        rm(l,i_h)    = zycol(l,g_h)    *zdens(l) 
+        rm(l,i_h2)   = zycol(l,g_h2)   *zdens(l) 
+        rm(l,i_oh)   = zycol(l,g_oh)   *zdens(l) 
+        rm(l,i_ho2)  = zycol(l,g_ho2)  *zdens(l)
+        rm(l,i_h2o2) = zycol(l,g_h2o2) *zdens(l) 
+        rm(l,i_h2o)  = zycol(l,g_h2o)  *zdens(l) 
+      enddo
+         
+      call flujo(solarcondate+zday/365.)
+
+      call jthermcalc
+     $ (rm(1,i_co2),rm(1,i_o2),rm(1,i_o),rm(1,i_h2),rm(1,i_h2o),
+     &  rm(1,i_h2o2),aux1,aux2,ztemp,nlayermx,zlocal,
+     &  solarcondate+zday/365.,zenit)
+
+      call paramfoto(lswitch,zdens,ztemp,ptimestep/3600.,zenit,
+     &             nlayer,rm(1,i_co2),rm(1,i_o2),rm(1,i_o),
+     &             rm(1,i_co),rm(1,i_h),rm(1,i_oh),rm(1,i_ho2),
+     &             rm(1,i_h2),rm(1,i_h2o),rm(1,i_h2o2),rm(1,i_o1d))
+
+      do l=lswitch,nlayer
+        zycol(l,g_co2)  = max(rm(l,i_co2)  / zdens(l) , 1.e-30)
+        zycol(l,g_co)   = max(rm(l,i_co)   / zdens(l) , 1.E-30)
+        zycol(l,g_o2)   = max(rm(l,i_o2)   / zdens(l) , 1.e-30)
+        zycol(l,g_h2)   = max(rm(l,i_h2)   / zdens(l) , 1.e-30)
+        zycol(l,g_h)    = max(rm(l,i_h)    / zdens(l) , 1.e-30)
+        zycol(l,g_oh)   = max(rm(l,i_oh)   / zdens(l) , 1.e-30)
+        zycol(l,g_ho2)  = max(rm(l,i_ho2)  / zdens(l) , 1.e-30)
+        zycol(l,g_h2o)  = max(rm(l,i_h2o)  / zdens(l) , 1.e-30)
+        zycol(l,g_h2o2) = max(rm(l,i_h2o2) / zdens(l) , 1.e-30)
+        zycol(l,g_o1d)  = max(rm(l,i_o1d)  / zdens(l) , 1.e-30)
+        zycol(l,g_o)    = max(rm(l,i_o)    / zdens(l) , 1.e-30)
+       enddo	!nlayer
+
+
+      return
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chimiedata.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chimiedata.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/chimiedata.h	(revision 57)
@@ -0,0 +1,61 @@
+c ------------------------------------
+c ---  Data for chemical routines  ---
+c ------------------------------------
+c    Author: Sebastien Lebonnois
+c            Franck Lefevre
+c    
+c  Update after water clouds included
+c ------------------------------------
+c
+      integer    nd, nozo, nr, nsza, ntemp
+c
+      parameter (nd    = 11)
+      parameter (nozo  = 7)
+      parameter (nr    = nd + 28)
+      parameter (nsza  = 27)
+      parameter (ntemp = 4)
+c
+      real       kb
+      parameter (kb = 1.38e-23)
+c
+c     factor: molecular gas constant/(boltzmann*gravity)
+c
+      real       factor
+      parameter (factor = 192./(kb*1.e4*3.72))
+c
+      common/chimiedata/reactifs,nprod,nperte,prod,perte,jphot,
+     $                  colairtab,table_ozo
+c
+c     used in obsolete scheme A :
+      integer    reactifs(nr,5),nprod(nqmx),nperte(nqmx)
+      integer    prod(nqmx,100),perte(nqmx,100,2)
+c
+c     VERSION: 28/05/2004  (update: Ar)
+c
+c     photodissociation rates matrix: version dependent
+c     for this version, file jmars.20030707
+c
+      real       jphot(ntemp,nsza,0:200,nozo,nd)
+      real       colairtab(0:200)
+      real       szatab(nsza)
+      real       table_ozo(nozo)
+c
+      data       szatab/0.,  5., 10., 15., 20., 25.,
+     $                 30., 35., 40., 45., 50., 55.,
+     $                 60., 65., 70., 75., 80., 82.,
+     $                 84., 86., 88., 90., 91., 92.,
+     $                 93., 94., 95./
+c
+c     compounds taken into account: version dependent
+c     DOES NOT INCLUDE h2o (always iq=nqmx)
+c            NOR water ice (if iceparty, iq=nqmx-1)
+c
+      integer       ncomp
+      parameter    (ncomp=13)
+      character*10  nomchem(ncomp)
+      data          nomchem/"co2","co","o","o1d","o2","o3","h","h2",
+     $                   "oh","ho2","h2o2", "n2", "ar"/
+c
+      real  mmolchem(ncomp)
+      data  mmolchem/44.,28.,16.,16.,32.,48.,1.,2.,17.,33.,34.,28.,40./
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/column.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/column.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/column.F	(revision 57)
@@ -0,0 +1,153 @@
+c**********************************************************************
+
+      subroutine column
+     $ (co2x,o2x,o3px,h2x,h2ox,h2o2x,tx,nz,iz,zenit,co2colx,o2colx,
+     $ o3pcolx,h2o2colx)
+
+
+c     nov 2002        fgg           first version
+
+c**********************************************************************
+
+      implicit none
+
+
+c     common variables and constants
+
+      include 'param.h'
+      include 'param_v3.h'
+
+
+
+c    local parameters and variables
+
+
+
+c     input and output variables
+
+      integer    nz
+      real       co2colx(nz)                 !column density of CO2 (cm^-2)
+      real       o2colx(nz)                  !column density of O2(cm^-2)
+      real       o3pcolx(nz)                 !column density of O(3P)(cm^-2)
+      real       h2o2colx(nz)                !column density of H2O2(cm^-2)
+      real       co2x(nz)                    !density of CO2(cm^-3)
+      real       o2x(nz)                     !density of O2(cm^-3)
+      real       o3px(nz)                    !density of O(3P)(cm^-3)
+      real       h2x(nz)                     !density of H2(cm^-3)
+      real       h2ox(nz)                    !density of H2O(cm^-3)
+      real       h2o2x(nz)                   !density of H2O2(cm^-3)
+      real       jtot(nz)                    !output: heating rate(erg/s)
+      real       tx(nz)                      !temperature profile
+      real       iz(nz+1)                    !height profile
+      real       zenit
+
+c     local variables
+
+      real       xx
+      real       grav(nzmax)
+      real       ntx(nzmax)
+      real       pmmixx(nzmax)
+      real       Hmix(nzmax)
+      real       nint(nzmax)
+      real       co2vmrx(nzmax)
+      real       o2vmrx(nzmax)
+      real       o3pvmrx(nzmax)
+      real       h2vmrx(nzmax)
+      real       h2ovmrx(nzmax)
+      real       h2o2vmrx(nzmax)
+      real       Hco2
+      real       Ho3p
+      real       Ho2
+      real       Hh2o2
+      real       chapm(nzmax)
+
+
+
+c     local variables
+
+      integer    i,j,k,icol,indexint          !indexes
+      real*8     znt
+
+c External functions
+
+       external    ch
+       real        ch
+
+
+c*************************PROGRAM STARTS*******************************
+
+      do i=1,nz
+         xx = ( radio + iz(i) ) * 1.e5
+         ntx(i)=co2x(i)+o2x(i)+o3px(i)+h2x(i)+h2ox(i)+h2o2x(i)
+         co2vmrx(i)=co2x(i)/ntx(i)
+         o2vmrx(i)=o2x(i)/ntx(i)
+         o3pvmrx(i)=o3px(i)/ntx(i)
+         h2vmrx(i)=h2x(i)/ntx(i)
+         h2ovmrx(i)=h2ox(i)/ntx(i)
+         h2o2vmrx(i)=h2o2x(i)/ntx(i)
+         pmmixx(i) = (pmco2*co2x(i)+pmo2*o2x(i) 
+     $                + pmo3p*o3px(i))/ntx(i)
+         grav(i) = gg * masa /(xx**2)
+         Hmix(i) = kboltzman*tx(i)*n_avog / (pmmixx(i)*grav(i))
+         nint(i) = -Hmix(i)*ntx(i)*
+     $   (exp((iz(i)-iz(i+1))*1e5/Hmix(i))-1)
+      end do
+
+      xx = kboltzman * tx(nz) * n_avog / grav(nz)
+      Ho3p = xx / pmo3p 
+      Hco2 = xx / pmco2
+      Ho2  = xx / pmo2
+      Hh2o2 = xx / pmh2o2
+      o3pcolx(nz) = o3px(nz) * Ho3p
+      co2colx(nz) = co2x(nz) * Hco2
+      h2o2colx(nz) = h2o2x(nz) * Hh2o2
+      o2colx(nz) = o2x(nz) * Ho2
+      do i=1,nz-1
+         co2colx(i) = co2colx(nz)
+         o2colx(i) = o2colx(nz)
+         o3pcolx(i) = o3pcolx(nz)
+         h2o2colx(i) = h2o2colx(nz)
+         do j=i,nz-1
+            co2colx(i) = co2colx(i) + nint(j) 
+     $                   * ((co2vmrx(j+1) + co2vmrx(j)) / 2.)
+            o2colx(i) = o2colx(i) + nint(j)
+     $                  * ((o2vmrx(j+1) + o2vmrx(j)) / 2.)
+            o3pcolx(i) = o3pcolx(i) + nint(j)
+     $                   * ((o3pvmrx(j+1) + o3pvmrx(j)) /2.)
+            h2o2colx(i) = h2o2colx(i) +nint(j)
+     $                     * ((h2o2vmrx(j+1) + h2o2vmrx(j)) / 2.)
+         end do
+      end do
+
+      znt=zenit*3.1416/180.
+      if(zenit.gt.80.0) then
+         do i=1,nz
+            chapm(i) =  
+     $           ch( (iz(i)+radio)/(Hmix(i)*1.e-5),znt)
+         enddo
+      end if
+      znt=zenit*3.1416/180.
+      do i=1,nz
+         if(zenit.le.80.0) then
+            co2colx(i)=co2colx(i)/cos(znt)
+            o2colx(i)=o2colx(i)/cos(znt)
+            o3pcolx(i)=o3pcolx(i)/cos(znt)
+            h2o2colx(i)=h2o2colx(i)/cos(znt)
+         else
+            co2colx(i)=co2colx(i)*chapm(i)
+            o2colx(i)=o2colx(i)*chapm(i)
+            o3pcolx(i)=o3pcolx(i)*chapm(i)
+            h2o2colx(i)=h2o2colx(i)*chapm(i)
+         end if
+      end do
+
+
+      return
+
+
+      end
+
+
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conc.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conc.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conc.h	(revision 57)
@@ -0,0 +1,18 @@
+c**********************************************************************
+
+c	conc.h
+	
+c**********************************************************************
+
+      integer ncomptot
+
+      parameter (ncomptot=ncomp+1)
+
+      common/conc/mmean,Akknew,cpnew,rnew
+ 
+      real mmean(ngridmx,nlayermx)
+      real Akknew(ngridmx,nlayermx)
+      real cpnew(ngridmx,nlayermx)
+      real rnew(ngridmx,nlayermx)
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/concentrations.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/concentrations.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/concentrations.F	(revision 57)
@@ -0,0 +1,177 @@
+      SUBROUTINE concentrations(pplay,pt,pdt,pq,pdq,ptimestep)
+                                             
+       IMPLICIT NONE
+c=======================================================================
+
+c CALCULATION OF MEAN MOLECULAR MASS, Cp, Akk and R
+c
+c mmean(ngridmx,nlayermx)			amu
+c cpnew(ngridmx,nlayermx)			J/kg/K
+c rnew(ngridmx,nlayermx)			J/kg/K
+c akknew(ngridmx,nlayermx)			coefficient of thermal concduction
+c
+c=======================================================================
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "conc.h"
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER ngrid,nlayer
+
+      REAL pplay(ngridmx,nlayermx)
+      REAL pt(ngridmx,nlayermx)
+      REAL pdt(ngridmx,nlayermx)
+      real pq(ngridmx,nlayermx,nqmx)
+      REAL pdq(ngridmx,nlayermx,nqmx)
+      REAL ptimestep
+
+c    Local variables :
+c    -----------------
+      INTEGER iq,l,ig,ll,n,k,nq
+      integer gind(ncomptot)
+      real ni(ncomptot)
+      real nt, ntot
+      real q2(ngridmx,nlayermx,ncomptot)
+      real zt(ngridmx,nlayermx)
+      real q2tot(ngridmx,nlayermx)
+      real aki(ncomptot)
+      real cpi(ncomptot)
+
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2,
+     $        i_o1d, i_o, i_h, i_oh, i_ho2, i_n2, i_o3, i_ar
+
+c      save    aki, cpi
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering for the thermal conduction and
+c     specific heat coefficients
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2  = 1
+      i_co   = 2
+      i_o    = 3
+      i_o1d  = 4
+      i_o2   = 5
+      i_o3   = 6
+      i_h    = 7
+      i_h2   = 8
+      i_oh   = 9
+      i_ho2  = 10
+      i_h2o2 = 11
+      i_n2   = 12
+      i_ar   = 13
+      i_h2o  = 14
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      gind(i_co2)   =  nqchem_min			! co2
+      gind(i_co)    =  nqchem_min + 1			! co
+      gind(i_o)     =  nqchem_min + 2			! o
+      gind(i_o1d)   =  nqchem_min + 3			! o1d
+      gind(i_o2)    =  nqchem_min + 4			! o2
+      gind(i_o3)    =  nqchem_min + 5			! o3
+      gind(i_h)     =  nqchem_min + 6			! h
+      gind(i_h2)    =  nqchem_min + 7			! h2
+      gind(i_oh)    =  nqchem_min + 8			! oh
+      gind(i_ho2)   =  nqchem_min + 9			! ho2
+      gind(i_h2o2)  =  nqchem_min + 10			! h2o2
+      gind(i_n2)    =  nqchem_min + 11			! n2
+      gind(i_ar)    =  nqchem_min + 12			! ar
+      gind(i_h2o)   =  nqmx				! h2o
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     Thermal conductivity and specific heat coefficients
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      aki(i_co2)  = 3.072e-4
+      aki(i_co)   = 4.87e-4
+      aki(i_o)    = 7.59e-4
+      aki(i_o1d)  = 7.59e-4		!?
+      aki(i_o2)   = 5.68e-4
+      aki(i_o3)   = 3.00e-4		!?
+      aki(i_h)    = 0.0
+      aki(i_h2)   = 36.314e-4
+      aki(i_oh)   = 7.00e-4		!?
+      aki(i_ho2)  = 0.0
+      aki(i_h2o2) = 0.0
+      aki(i_n2)   = 5.6e-4
+      aki(i_ar)   = 0.0                 !?
+      aki(i_h2o)  = 0.0
+
+      cpi(i_co2)   = 0.834e3
+      cpi(i_co)    = 1.034e3
+      cpi(i_o)     = 1.3e3
+      cpi(i_o1d)   = 1.3e3		!?
+      cpi(i_o2)    = 0.9194e3
+      cpi(i_o3)    = 0.800e3	!?
+      cpi(i_h)     = 20.780e3
+      cpi(i_h2)    = 14.266e3
+      cpi(i_oh)    = 1.045e3
+      cpi(i_ho2)   = 1.065e3	!?
+      cpi(i_h2o2)  = 1.000e3	!?
+      cpi(i_n2)    = 1.034e3
+      cpi(i_ar)    = 1.000e3    !?
+      cpi(i_h2o)   = 1.870e3
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      nlayer=nlayermx
+      ngrid=ngridmx
+      nq=nqmx
+
+      DO l=1,nlayer
+        DO ig=1,ngrid
+          DO n=1,ncomptot
+            q2(ig,l,n)=max(1.e-30,
+     .         pq(ig,l,gind(n))+pdq(ig,l,gind(n))*ptimestep)
+          ENDDO
+          zt(ig,l)=pt(ig,l) +pdt(ig,l)*ptimestep
+        ENDDO
+      ENDDO
+  
+      do l=1,nlayermx
+        do ig=1,ngridmx
+          ntot=pplay(ig,l)/(1.381e-23*zt(ig,l))*1.e-6  ! in #/cm3
+          cpnew(ig,l)=0.
+          akknew(ig,l)=0.
+          mmean(ig,l)=0.
+          q2tot(ig,l)=0.
+          nt=0.
+          do n=1,ncomptot
+            ni(n)=0.0 
+            do k=1,ncomptot
+              if(k.ne.n) ni(n)=ni(n)+q2(ig,l,k)/mmol(gind(k))
+            enddo
+            ni(n)=ntot/(1.+mmol(gind(n))/q2(ig,l,n)*ni(n))
+            cpnew(ig,l)=cpnew(ig,l)+ni(n)*cpi(n)
+            akknew(ig,l)=akknew(ig,l)+ni(n)*aki(n)
+            mmean(ig,l)=mmean(ig,l)+q2(ig,l,n)/mmol(gind(n))
+            q2tot(ig,l)=q2tot(ig,l)+q2(ig,l,n)
+c        if(ig.eq.1.and.l.eq.1) write(*,*)'q2tot(ig,l)',n,q2tot(ig,l) 
+            if(cpi(n) .ne. 0.0) nt=nt+ni(n)
+          enddo 
+
+c     print*,"concentrations rep 3",l,ig,nt,mmean(ig,l),zt(ig+1,l)
+
+          cpnew(ig,l)=cpnew(ig,l)/nt
+          akknew(ig,l)=akknew(ig,l)/nt
+          mmean(ig,l)=1/mmean(ig,l)    ! in amu
+          rnew(ig,l)=8.314/mmean(ig,l)*1.e3     ! J/kg/K		
+        enddo
+c        print*,l,mmean(1,l),cpnew(1,l),rnew(1,l)
+c         write(228,*),l,pplay(1,l),ntot
+      enddo
+      return
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conduction.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conduction.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/conduction.F	(revision 57)
@@ -0,0 +1,179 @@
+       SUBROUTINE conduction(ptimestep,pplay,pplev,pt,pdt,
+     $                   tsurf,zzlev,zzlay,zdtconduc)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Molecular thermal conduction
+c   
+c   N. Descamp, F. Forget 05/1999
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c-----------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "surfdat.h"
+#include "chimiedata.h"
+#include "conc.h"
+
+c   arguments:
+c   ----------
+
+      REAL ptimestep
+      REAL pplay(ngridmx,nlayermx)
+      real pplev(ngridmx,nlayermx+1)
+      REAL zzlay(ngridmx,nlayermx)
+      real zzlev(ngridmx,nlayermx+1)
+      REAL pt(ngridmx,nlayermx)
+      real pdt(ngridmx,nlayermx)
+      real tsurf(ngridmx)
+
+      real zdtconduc(ngridmx,nlayermx)
+
+c   local:
+c   ------
+
+      INTEGER i,ig,l, ngrid, nz
+      real Akk,skk,phitop,m,tmean
+      REAL alpha(nlayermx)
+      real zt(nlayermx)
+      REAL lambda(nlayermx)
+      real muvol(nlayermx)
+      REAL C(nlayermx)
+      real D(nlayermx)
+      real den(nlayermx)
+      REAL pdtc(nlayermx)
+      real zlay(nlayermx)
+      real zlev(nlayermx+1)
+
+c   constants used locally
+c    ---------------------
+c     The atmospheric conductivity is a function of temperature T :
+c      conductivity = Akk* T**skk
+      PARAMETER (skk=0.69)
+      
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+c-----------------------------------------------------------------------
+c   calcul des coefficients alpha et lambda
+c-----------------------------------------------------------------------
+
+      IF (firstcall) THEN
+        write (*,*)'conduction: coeff to compute molecular',
+     &             ' conductivity Akk,skk'
+        write(*,*) Akk,skk
+        firstcall = .false.
+      END IF
+
+! Initialize phitop
+      phitop=0.0
+      
+      ngrid=ngridmx
+      nz=nlayermx
+
+      do ig=1,ngrid
+
+        zt(1)=pt(ig,1)+pdt(ig,1)*ptimestep
+c        zlay(1)=-log(pplay(ig,1)/pplev(ig,1))*Rnew(ig,1)*zt(1)/g
+c        zlev(1)=0.0
+        zlay(1)=zzlay(ig,1)
+        zlev(1)=zzlev(ig,1)
+      
+        do i=2,nz
+
+          zt(i)=pt(ig,i)+pdt(ig,i)*ptimestep 
+c          tmean=zt(i)
+c          if(zt(i).ne.zt(i-1))
+c     &    tmean=(zt(i)-zt(i-1))/log(zt(i)/zt(i-1))
+c          zlay(i)= zlay(i-1)
+c     &          -log(pplay(ig,i)/pplay(ig,i-1))*Rnew(ig,i-1)*tmean/g
+c          zlev(i)= zlev(i-1)
+c     &         -log(pplev(ig,i)/pplev(ig,i-1))*Rnew(ig,i-1)*tmean/g
+        zlay(i)=zzlay(ig,i)
+        zlev(i)=zzlev(ig,i)
+        enddo
+        
+c        zlev(nz+1)= zlev(nz)
+c     &         -log(max(pplev(ig,nz+1),1.e-30)/pplev(ig,nz))
+c     &           *Rnew(ig,nz)*tmean/g
+c        if(pplev(ig,nz+1).eq.0.) 
+c     &     zlev(nz+1)=zlev(nz)+(zlay(nz)-zlay(nz-1))
+      
+        zlev(nz+1)= zlev(nz)+10000.
+
+        Akk=Akknew(ig,1) 
+        lambda(1) = Akk*tsurf(ig)**skk/zlay(1)   
+
+        DO i = 2 , nz
+          Akk=Akknew(ig,i) 
+          lambda(i)=Akk*zt(i)**skk/(zlay(i)-zlay(i-1)) 
+        ENDDO
+        DO i=1,nz-1
+          muvol(i)=pplay(ig,i)/(rnew(ig,i)*zt(i)) 
+          alpha(i)=cpnew(ig,i)*(muvol(i)/ptimestep)
+     $                        *(zlev(i+1)-zlev(i))
+        ENDDO
+
+        muvol(nz)=pplay(ig,nz)/(rnew(ig,nz)*zt(nz)) 
+        alpha(nz)=cpnew(ig,i)*(muvol(nz)/ptimestep)
+     $                       *(zlev(nz+1)-zlev(nz))
+
+c--------------------------------------------------------------------
+c
+c     calcul des coefficients C et D
+c
+c-------------------------------------------------------------------
+
+      den(1)=alpha(1)+lambda(2)+lambda(1)
+      C(1)=lambda(1)*(tsurf(ig)-zt(1))+lambda(2)*(zt(2)-zt(1))
+      C(1)=C(1)/den(1)	     
+      D(1)=lambda(2)/den(1)           
+   
+      DO i = 2,nz-1
+        den(i)=alpha(i)+lambda(i+1)
+        den(i)=den(i)+lambda(i)*(1-D(i-1))
+         
+        C(i) =lambda(i+1)*(zt(i+1)-zt(i)) 
+     $       +lambda(i)*(zt(i-1)-zt(i)+C(i-1))    
+        C(i) =C(i)/den(i)           
+
+        D(i) =lambda(i+1) / den(i)
+      ENDDO 
+
+      den(nz)=alpha(nz) + lambda(nz) * (1-D(nz-1))
+      C(nz)=C(nz-1)+zt(nz-1)-zt(nz) 
+      C(nz)=(C(nz)*lambda(nz)+phitop) / den(nz) 
+       	 	
+c----------------------------------------------------------------------
+c
+c      calcul de la nouvelle temperature ptconduc
+c
+c----------------------------------------------------------------------
+
+      DO i=1,nz
+        pdtc(i)=0.
+      ENDDO
+      pdtc(nz)=C(nz)
+      DO i=nz-1,1,-1
+        pdtc(i)=C(i)+D(i)*pdtc(i+1)
+      ENDDO 
+c-----------------------------------------------------------------------
+c
+c     calcul de la tendance zdtconduc
+c
+c-----------------------------------------------------------------------
+    
+      DO i=1,nz
+        zdtconduc(ig,i)=pdtc(i)/ptimestep
+      ENDDO
+
+      ENDDO             ! boucle sur ngrid
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/dtridgl.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/dtridgl.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/dtridgl.F	(revision 57)
@@ -0,0 +1,36 @@
+      SUBROUTINE DTRIDGL(L,AF,BF,CF,DF,XK)
+
+C  GCM2.0  Feb 2003
+
+C     DOUBLE PRECISION VERSION OF TRIDGL
+
+      PARAMETER (NMAX=201)
+      IMPLICIT REAL*8  (A-H,O-Z)
+      DIMENSION AF(L),BF(L),CF(L),DF(L),XK(L)
+      DIMENSION AS(NMAX),DS(NMAX)
+
+C*    THIS SUBROUTINE SOLVES A SYSTEM OF TRIDIAGIONAL MATRIX
+C*    EQUATIONS. THE FORM OF THE EQUATIONS ARE:
+C*    A(I)*X(I-1) + B(I)*X(I) + C(I)*X(I+1) = D(I)
+C*    WHERE I=1,L  LESS THAN 103.
+C* ..............REVIEWED -CP........
+
+C======================================================================C
+
+      AS(L) = AF(L)/BF(L)
+      DS(L) = DF(L)/BF(L)
+
+      DO I=2,L
+        X         = 1./(BF(L+1-I) - CF(L+1-I)*AS(L+2-I))
+        AS(L+1-I) = AF(L+1-I)*X
+        DS(L+1-I) = (DF(L+1-I)-CF(L+1-I)*DS(L+2-I))*X
+      END DO
+ 
+      XK(1)=DS(1)
+      DO I=2,L
+        XKB   = XK(I-1)
+        XK(I) = DS(I)-AS(I)*XKB
+      END DO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/euvheat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/euvheat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/euvheat.F	(revision 57)
@@ -0,0 +1,183 @@
+      SUBROUTINE euvheat(pt,pdt,pplev,pplay,zzlay,dist_sol,
+     $     mu0,ptimestep,ptime,zday,pq,pdq,pdteuv)
+
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing heating rate due to EUV absorption
+c
+c   author:  MAC 2002
+c   ------
+c
+c   input:
+c   ----- 
+c   dist_sol		  sun-Mars distance (AU)
+c   mu0(ngridmx)           
+c   pplay(ngrid,nlayer)   pressure at middle of layers (Pa)
+c
+c   output:
+c   -------
+c
+c   pdteuv(ngrid,nlayer)      Heating rate (K/s)
+c
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "param.h"
+#include "param_v3.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "conc.h"
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+
+      REAL pplay(ngridmx,nlayermx)
+      REAL zzlay(ngridmx,nlayermx)
+      real pplev(ngridmx,nlayermx+1)
+      REAL pt(ngridmx,nlayermx)
+      REAL pdt(ngridmx,nlayermx)
+      real zday
+      REAL dist_sol
+      real mu0(ngridmx)
+      real pq(ngridmx,nlayermx,nqmx)
+      real pdq(ngridmx,nlayermx,nqmx)
+      real ptimestep,ptime
+
+
+      REAL pdteuv(ngridmx,nlayermx)
+c
+c    Local variables :
+c    -----------------
+      integer nespeuv
+      parameter (nespeuv=6)
+
+      INTEGER l,iq,ig,n,inif ! , ngrid, nlayer
+      real rm(nlayermx,nespeuv)				! number density (cm-3)
+      real zq(ngridmx,nlayermx,nqmx)
+      real zt(ngridmx,nlayermx)
+      real zlocal(nlayermx)
+      real zenit
+      real aux1(nlayermx)
+      real aux2(nlayermx)
+      real jtot(nlayermx)
+      real dens								! amu/cm-3
+      real tx(nlayermx)
+      real tmean
+      
+      integer i_co2, i_o2, i_h2, i_h2o, i_h2o2, i_o
+      integer g_co2, g_co, g_o2, g_h2, g_h2o, g_h2o2,
+     $        g_o1d, g_o, g_h, g_oh, g_ho2, g_o3, g_n2
+
+
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+
+      if (firstcall) then
+        if ((nqchem_min+nespeuv).gt.nqmx) then
+          print*,'******* Dimension problem in EUVHEAT ********'
+          STOP
+        endif
+
+        firstcall= .false.
+!        print*,'EUV',nlayer,nlayermx,ngrid,ngridmx   
+      endif
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      g_co2      =  nqchem_min
+      g_co       =  nqchem_min + 1
+      g_o        =  nqchem_min + 2
+      g_o1d      =  nqchem_min + 3
+      g_o2       =  nqchem_min + 4
+      g_o3       =  nqchem_min + 5
+      g_h        =  nqchem_min + 6
+      g_h2       =  nqchem_min + 7
+      g_oh       =  nqchem_min + 8
+      g_ho2      =  nqchem_min + 9
+      g_h2o2     =  nqchem_min + 10
+      g_n2       =  nqchem_min + 11
+      g_h2o      =  nqmx
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the EUV heating
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2  = 1
+      i_o2   = 2
+      i_o    = 3
+      i_h2   = 4
+      i_h2o  = 5
+      i_h2o2 = 6
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do l=1,nlayermx
+        do ig=1,ngridmx
+          do iq=nqchem_min,nqmx
+            zq(ig,l,iq)=pq(ig,l,iq)+pdq(ig,l,iq)*ptimestep
+          enddo
+          zt(ig,l)=pt(ig,l)+pdt(ig,l)*ptimestep
+        enddo
+      enddo
+
+      call flujo(solarcondate)
+c     call flujo(solarcondate+zday/365.) ! version with EUV time evolution
+
+      do ig=1,ngridmx
+
+        zenit=acos(mu0(ig))*180./acos(-1.)
+ 
+        do l=1,nlayermx
+          dens=pplay(ig,l)/(rnew(ig,l)*zt(ig,l)) / 1.66e-21
+          rm(l,i_co2)  = zq(ig,l,g_co2)  * dens / mmol(g_co2)
+          rm(l,i_o2)   = zq(ig,l,g_o2)   * dens / mmol(g_o2)
+          rm(l,i_o)    = zq(ig,l,g_o)    * dens / mmol(g_o)
+          rm(l,i_h2)   = zq(ig,l,g_h2)   * dens / mmol(g_h2)
+          rm(l,i_h2o)  = zq(ig,l,g_h2o)  * dens / mmol(g_h2o)
+          rm(l,i_h2o2) = zq(ig,l,g_h2o2) * dens / mmol(g_h2o2)
+        enddo
+
+c        zlocal(1)=-log(pplay(ig,1)/pplev(ig,1))
+c     &            *Rnew(ig,1)*zt(ig,1)/g
+        zlocal(1)=zzlay(ig,1)
+        zlocal(1)=zlocal(1)/1000.
+        tx(1)=zt(ig,1)
+
+        do l=2,nlayermx
+          tx(l)=zt(ig,l)
+          tmean=tx(l)
+          if(tx(l).ne.tx(l-1))
+     &    tmean=(tx(l)-tx(l-1))/log(tx(l)/tx(l-1))
+c          zlocal(l)= zlocal(l-1)
+c     &   -log(pplay(ig,l)/pplay(ig,l-1))*Rnew(ig,l-1)*tmean/g/1000.
+        zlocal(l)=zzlay(ig,l)/1000.
+        enddo
+
+        call hrtherm (rm(1,i_co2),rm(1,i_o2),rm(1,i_o),
+     &                rm(1,i_h2),rm(1,i_h2o),rm(1,i_h2o2),
+     &                aux1,aux2,tx,nlayermx,zlocal,
+     &                solarcondate+zday/365.,zenit,jtot)
+
+        do l=1,nlayermx
+          pdteuv(ig,l)=0.16*jtot(l)/10.
+     &            /(cpnew(ig,l)*pplay(ig,l)/(rnew(ig,l)*zt(ig,l)))
+     &                  *(1.52/dist_sol)**2 
+
+        enddo	
+
+      enddo  ! of do ig=1,ngridmx
+
+      return
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/flujo.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/flujo.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/flujo.F	(revision 57)
@@ -0,0 +1,48 @@
+c***************************************************
+
+      subroutine flujo(date)
+
+
+c     fgg           nov 2002     first version
+c***************************************************
+
+      implicit none
+
+
+c     common variables and constants
+
+      include 'param.h'
+      include 'param_v3.h'
+
+
+c     Arguments
+
+      real date
+
+
+c     Local variable and constants
+
+      integer i
+      integer inter
+      real    nada
+
+c*************************************************
+
+      if(date.lt.1985.) date=1985.
+      if(date.gt.2001.) date=2001.
+      
+      do i=1,ninter
+        if(i.le.24) then
+          fluxtop(i)=(((ct1(i)+p1(i)*date)/2.)
+     $                *sin(2.*3.1416/11.*(date-1985.-3.1416))
+     $                +(ct2(i)+p2(i)*date)+1.)*fluxtophr(i)
+        else
+          fluxtop(i)=fluxtophr(i)
+        end if
+      end do
+     
+      return
+      end
+      
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/getch.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/getch.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/getch.F	(revision 57)
@@ -0,0 +1,76 @@
+c***************************************************************************
+       subroutine getch (tt)
+
+c	NOV 98	MALV 		First Version. From the work:
+c                               Rodrigo et al, Atmosfera, 3, pp.31-43, 19990
+c       apr 02  FGG             New reactions
+c       jul 03  MAC             Updated to agree with lower atmosphere
+c***************************************************************************
+	
+      implicit none
+
+      include 'param.h'
+      include 'param_v3.h'
+
+c Arguments 	
+      real*8 		tt		! Temperature 
+
+
+c**************************************************************************
+
+ch2: h + o2 + co2 --> ho2 + co2
+      ch2 = 1.3d-31 * exp(tt / 300.) ** (-1.6)
+
+ch3: o + ho2 --> oh + o2
+      ch3 = 3.0d-11 * exp(200.d0 / tt)
+
+ch4: co + oh --> co2 + h
+      ch4 = 1.57d-13 + 3.54d-33
+
+ch5: ho2 + ho2 --> h2o2 + o2
+      ch5 = 1.5d-12 * exp(19.d0 / tt)
+
+ch7: oh + ho2 --> h2o + o2
+      ch7 = 4.8d-11 * exp(250.d0 / tt)
+
+ch9: o(1d) + h2o --> 2oh
+      ch9 = 2.2d-10
+
+ch10: o + o + co2 --> o2 + co2
+      ch10 = 2.5 * 5.2d-35 * exp(900. / tt) 
+
+ch11: o + oh --> o2 + h
+      ch11 = 2.2d-11 * exp(120.d0 / tt)
+
+ch13: h + ho2 --> h2 + o2
+      ch13 = 6.48d-12
+
+ch14: o(1d) + h2 --> h + oh
+      ch14 = 1.1d-10
+
+ch15: oh + h2 --> h + h2o
+      ch15 = 5.5d-12 * exp (-2000.d0 / tt)
+
+ch18: oh + h2o2 --> h2o + ho2
+      ch18 = 2.9d-12 * exp (-160.d0 / tt)
+
+ch19: o(1d) + co2 --> o + co2
+      ch19 = 7.4d-11 * exp(120.d0 / tt)
+
+ch20: o(1d) + o2 --> o + o2
+      ch20 = 3.2d-11 * exp (70.d0 / tt)
+
+ch21: o + o2 + co2 --> o3 + co2
+      ch21 = 2.5 * 6.0d-34 * (tt / 300.) ** (-2.4) 
+
+      return 
+      end
+
+
+
+
+
+
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/hrtherm.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/hrtherm.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/hrtherm.F	(revision 57)
@@ -0,0 +1,100 @@
+c**********************************************************************
+
+      subroutine hrtherm
+     $ (co2x,o2x,o3px,h2x,h2ox,h2o2x,aux1,aux2,tx,nz,iz,date,zenit,jtot)
+
+
+c     feb 2002        fgg           first version
+c     nov 2002        fgg           second version
+
+c**********************************************************************
+
+      implicit none
+
+c     common variables and constants
+
+      include 'param.h'
+      include 'param_v3.h'
+      include 'callkeys.h'
+
+
+c    local parameters and variables
+
+      real       xabsi(nabs,nzmax) 			!densities
+      real       nada
+      real       jergs(ninter,nabs,nzmax)
+      
+      integer    i,j,k,indexint          !indexes
+      character  dn
+
+
+c     input and output variables
+
+      integer    nz                          !number of layers
+      real       co2x(nz)                    !density of CO2(cm^-3)
+      real       o2x(nz)                     !density of O2(cm^-3)
+      real       o3px(nz)                    !density of O(3P)(cm^-3)
+      real       h2x(nz)                     !density of H2(cm^-3)
+      real       h2ox(nz)                    !density of H2O(cm^-3)
+      real       h2o2x(nz)                   !density of H2O2(cm^-3)
+      real       aux1(nz)	  	             !auxiliar variable
+      real       aux2(nz)                    !auxiliar variable
+      real       jtot(nz)                    !output: heating rate(erg/s)
+      real       tx(nz)                      !temperature
+      real       date
+      real       zenit
+      real       iz(nz)
+
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+
+c*************************PROGRAM STARTS*******************************
+
+c      if (firstcall) then
+c        if(.not. thermochem) call param_read
+c        firstcall= .false.
+c      endif
+
+      if(zenit.gt.100.) then
+         dn='n'
+         else
+         dn='d'
+      end if
+      if(dn.eq.'n') then
+        do i=1,nz                                    
+	      jtot(i)=0.
+        enddo       
+        return
+      endif 
+     
+      do i=1,nz
+         xabsi(1,i) = co2x(i)
+         xabsi(2,i) = o2x(i)
+         xabsi(3,i) = o3px(i)
+         xabsi(4,i) = h2ox(i)
+         xabsi(5,i) = h2x(i)
+         xabsi(6,i) = h2o2x(i)
+         jtot(i) = 0.
+      end do
+
+      if(.not. thermochem) then
+        call jthermcalc
+     $ (co2x,o2x,o3px,h2x,h2ox,h2o2x,aux1,aux2,tx,nz,iz,date,zenit)
+      endif
+
+      do i=1,nz
+        do j=1,nabs
+          do indexint=1,33
+            jergs(indexint,j,i) = jfotsout(indexint,j,i) 
+     $              * xabsi (j,i) * fluxtop(indexint)  
+     $              / (0.5e9 * freccen(indexint))
+            jtot(i)=jtot(i)+jergs(indexint,j,i)
+          end do
+        end do
+      end do
+
+      return
+
+      end
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim.F	(revision 57)
@@ -0,0 +1,309 @@
+      subroutine inichim(pq,sig)
+
+      implicit none
+
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c  Initialization of the composition for use in testphys1d.F
+c
+c   Author:   Sebastien Lebonnois (08/11/2002)
+c   -------
+c            update 12/06/2003
+c            update july 2003: Monica Angelats-i-Coll
+c
+c   Arguments:
+c   ----------
+c
+c    pq(ngridmx,nlayermx,nqmx)  Advected fields, ie chemical species here
+c    sig = sigma                vertical coordinate (interface of layers)
+c
+c=======================================================================
+
+c    Declarations :
+c    --------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "datafile.h"
+
+c Arguments :
+c -----------
+
+      real    pq(ngridmx,nlayermx,nqmx)  ! chemical species mass mixing ratio
+      real    sig(llm+1)                 ! vertical coordinate (interface of layers)
+
+c Local variables :
+c -----------------
+
+      integer  ig,l,iq, n,i,j,iqmax
+      real     zy(ngridmx,nlayermx,nqmx) ! Composition in MOLE fractions
+      REAL qtot(ngridmx,nlayermx)
+      INTEGER aa(nqmx)  ! relation GCM<->files
+      real densconc,zgcm,zfile(252),vmrint,nt, mmean
+      real nxf(252),zfilemin(252),sigfile(252)
+      real vmrf(252,14),nf(252,14)
+      real tfile(252),zzfile(252)
+      real ni(14)       ! densities from files (interpolated for GCM)
+
+      real mmolf(14)    ! molecular mass in amu (species in files)
+      data mmolf/44.,40.,28.,32.,28.,16.,2.,   ! majors
+     .           1.,17.,33.,18.,34.,16.,48./   ! minors
+
+      character*3 tmp  ! temporary variable
+      integer ierr,lnblnk
+      external lnblnk
+
+
+c Dimension test:
+c ---------------
+
+       if (iceparty) then
+         if ((nqchem_min+ncomp+1).ne.nqmx) then
+            print*,'********* Dimension problem! ********'
+            print*,"nqchem_min+ncomp+1).ne.nqmx"
+            print*,"ncomp: ",ncomp
+            print*,"nqchem_min: ",nqchem_min
+            print*,"nqmx: ",nqmx
+            print*,'Change ncomp in chimiedata.h'
+            STOP
+         endif
+       else
+         if ((nqchem_min+ncomp).ne.nqmx) then
+            print*,'********* Dimension problem! ********'
+            print*,"nqchem_min+ncomp).ne.nqmx"
+            print*,"ncomp: ",ncomp
+            print*,"nqchem_min: ",nqchem_min
+            print*,"nqmx: ",nqmx
+            print*,'Change ncomp in chimiedata.h'
+            STOP
+         endif
+       endif
+
+c noms and mmol vectors:
+c ----------------------
+
+       if (iceparty) then
+          do iq=nqchem_min,nqmx-2
+            noms(iq) = nomchem(iq-nqchem_min+1)
+            mmol(iq) = mmolchem(iq-nqchem_min+1)
+          enddo
+          noms(nqmx-1) = 'ice'
+          mmol(nqmx-1) = 18.
+          noms(nqmx)   = 'h2o'
+          mmol(nqmx)   = 18.
+       else
+          do iq=nqchem_min,nqmx-1
+            noms(iq) = nomchem(iq-nqchem_min+1)
+            mmol(iq) = mmolchem(iq-nqchem_min+1)
+          enddo
+          noms(nqmx)   = 'h2o'
+          mmol(nqmx)   = 18.
+       endif
+       if (nqchem_min.gt.1) then
+          do iq=1,nqchem_min-1
+            noms(iq) = 'dust'
+            mmol(iq) = 100.
+          enddo
+       endif
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     co2      =  nqchem_min
+c     co       =  nqchem_min + 1
+c     o        =  nqchem_min + 2
+c     o(1d)    =  nqchem_min + 3
+c     o2       =  nqchem_min + 4
+c     o3       =  nqchem_min + 5
+c     h        =  nqchem_min + 6
+c     h2       =  nqchem_min + 7
+c     oh       =  nqchem_min + 8
+c     ho2      =  nqchem_min + 9
+c     h2o2     =  nqchem_min + 10
+c     n2       =  nqchem_min + 11
+c     ar       =  nqchem_min + 12
+c     h2o      =  nqmx
+c
+c----------------------------------------------------------------------
+c Major species in files:
+c
+c       1=CO2
+c       2=AR
+c       3=N2
+c       4=O2
+c       5=CO
+c       6=O
+c       7=H2
+c
+c Minor species in files:
+c
+c       1=H
+c       2=OH
+c       3=HO2
+c       4=H2O
+c       5=H2O2
+c       6=O1D
+c       7=O3
+c
+c----------------------------------------------------------------------
+c Major species:
+        aa(nqchem_min)      = 1
+        aa(nqchem_min + 12) = 2
+        aa(nqchem_min + 11) = 3
+        aa(nqchem_min + 4)  = 4
+        aa(nqchem_min + 1)  = 5
+        aa(nqchem_min + 2)  = 6
+        aa(nqchem_min + 7)  = 7
+c Minor species:
+        aa(nqchem_min + 6)  = 8
+        aa(nqchem_min + 8)  = 9
+        aa(nqchem_min + 9)  = 10
+        aa(nqmx)            = 11
+        aa(nqchem_min + 10) = 12
+        aa(nqchem_min + 3)  = 13
+        aa(nqchem_min + 5)  = 14
+c----------------------------------------------------------------------
+
+      open(210, iostat=ierr,file=
+     & datafile(1:lnblnk(datafile))//'/atmosfera_LMD_may.dat')
+      if (ierr.ne.0) then
+        write(*,*)'Error : cannot open file atmosfera_LMD_may.dat '
+        write(*,*)'(in aeronomars/inichim.F)'
+        write(*,*)'It should be in :', datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary atmosfera_LMD_may.dat (and others)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+         STOP
+      endif
+      open(220, iostat=ierr,file=
+     & datafile(1:lnblnk(datafile))//'/atmosfera_LMD_min.dat')
+      if (ierr.ne.0) then
+        write(*,*)'Error : cannot open file atmosfera_LMD_min.dat '
+        write(*,*)'(in aeronomars/inichim.F)'
+        write(*,*)'It should be in :', datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary atmosfera_LMD_min.dat (and others)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+         STOP
+      endif
+      read(210,*) tmp
+      read(220,*) tmp
+        do l=1,252
+          read(210,112) tfile(l),zfile(l),nxf(l),(vmrf(l,n),n=1,7)
+          zfile(l)=zfile(l)*100.                    !pressure (Pa)
+          sigfile(l)=zfile(l)/zfile(1)
+        enddo
+        do l=1,252
+          read(220,113)zfilemin(l),(vmrf(l,n),n=8,14)
+          zfilemin(l)=zfilemin(l)*1000.             !height (m)
+          do n=1,14
+            nf(l,n)=vmrf(l,n)*nxf(l)
+          enddo
+        enddo
+        close(210)
+        close(220)
+
+      do i=1,ngridmx
+         do l=1,nlayermx
+
+          zgcm=sig(l)
+
+          do n=1,14
+            call intrplf(zgcm,vmrint,sigfile,nf(1,n),252)
+            ni(n)=vmrint
+          enddo
+
+          densconc=0.
+          nt=0.
+
+          do n=1,14
+            densconc=densconc+ni(n)*mmolf(n)
+            nt=nt+ni(n)
+          enddo
+
+          mmean=densconc/nt                            ! in amu
+
+c TEST
+c           print*,l," mmean=",mmean
+c           print*,l," nt=",nt
+c FIN TEST
+
+          do n=nqchem_min,nqmx-2
+            pq(i,l,n)=ni(aa(n))/nt*mmol(n)/mmean
+          enddo
+          if (iceparty) then
+            pq(i,l,nqmx-1) = 0.
+            pq(i,l,nqmx)   = ni(aa(nqmx))/nt*mmol(nqmx)/mmean
+          else
+           do n=nqmx-1,nqmx
+            pq(i,l,n)=ni(aa(n))/nt*mmol(n)/mmean
+           enddo
+          endif
+
+c TEST
+c        if (noms(n).eq."h2o") then
+c           print*,l," ",noms(n)," ni=",ni(aa(n))," q=",pq(i,l,n)
+c        endif
+c FIN TEST
+
+c          pq(i,l,nqchem_min)=0.995
+c          do n=nqchem_min+1, nqmx
+c            pq(i,l,n)=0.005/12
+c          enddo
+
+          enddo     
+        enddo   
+
+cccccccccccccccccccccccccccccc      
+c  make sure that sum of q = 1      
+c dominent species is = 1 - sum(all other species)      
+cccccccccccccccccccccccccccccc      
+      iqmax=nqchem_min
+      
+      if ((nqmx-nqchem_min).gt.10) then
+       do l=1,nlayermx
+        do j=1,ngridmx
+           do iq=nqchem_min,nqmx
+            if ( (pq(j,l,iq).gt.pq(j,l,iqmax)).and.
+     .           (noms(iq).ne."ice") )  then 
+              iqmax=iq
+            endif
+           enddo
+           pq(j,l,iqmax)=1.
+           qtot(j,l)=0
+           do iq=nqchem_min,nqmx
+            if ( (iq.ne.iqmax).and.
+     .           (noms(iq).ne."ice") ) then        
+              pq(j,l,iqmax)=pq(j,l,iqmax)-pq(j,l,iq)        
+            endif
+           enddo !iq
+           do iq=nqchem_min,nqmx
+            if (noms(iq).ne."ice") then
+             qtot(j,l)=qtot(j,l)+pq(j,l,iq)
+            endif
+c            if (j.eq.1.and.l.eq.1) write(*,*)' qtot(j,l)',
+c     $    qtot(j,l)
+           enddo !iq
+         enddo !j   
+       enddo !l  
+      endif
+ccccccccccccccccccccccccccccccc
+
+66      format(i2,6(1x,e11.5))
+112     format(7x,f7.3,3x,e12.6,3x,e12.6,6(3x,e12.6))
+113     format(1x,f6.2,7(3x,e12.6))
+
+      end
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_newstart.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_newstart.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_newstart.F	(revision 57)
@@ -0,0 +1,337 @@
+      subroutine inichim_newstart(pq,ps,sig,nq,latfi,lonfi,airefi,
+     $ thermo)
+
+      implicit none
+
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c  Initialization of the composition for use in the building of a new start file
+c  using newstart.F
+c
+c   Author:   Sebastien Lebonnois (08/11/2002)
+c   -------
+c Revised 07/2003 by Monica Angelats-i-Coll to use input files
+c
+c   Arguments:
+c   ----------
+c
+c    pq(iip1,jjp1,llm,nqmx)  Advected fields, ie chemical species here
+c    sig = sigma                vertical coordinate (interface of layers)
+c    nq: permet de ne pas modifier l'eau (et la glace d'eau si iceparty)
+c
+c=======================================================================
+
+c    Declarations :
+c    --------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "comcstfi.h"
+#include "comdiurn.h"
+#include "callkeys.h"
+#include "temps.h"
+#include "datafile.h"
+
+c Arguments :
+c -----------
+
+      real    ps(iip1,jjp1)
+      real    pq(iip1,jjp1,llm,nqmx)     ! Advected fields, ie chemical species
+      real    sig(llm+1)                 ! vertical coordinate (interface of layers)
+      integer nq                         !    =nqmx 
+                                         ! or =nqmx-1 if H2O kept
+                                         ! or =nqmx-2 if H2O and ice kept
+      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
+      integer thermo ! flag for thermosphere initialisation only
+
+c Local variables :
+c -----------------
+
+      integer  iq,i,j,l,n, nspecini,inil,iqmax
+      INTEGER aa(nqmx)
+      REAL qtot(iip1,jjp1,llm)
+      real densconc,zgcm,zfile(252),vmrint,nt, mmean
+      real nxf(252),zfilemin(252),sigfile(252)
+      real vmrf(252,14),nf(252,14)
+      real tfile(252),zzfile(252)
+      real ni(14),niold(14)
+      real mmolf(14)    ! molecular mass in amu (species in files)
+      data mmolf/44.,40.,28.,32.,28.,16.,2.,   ! majors
+     &           1.,17.,33.,18.,34.,16.,48./   ! minors
+      character*3 tmp ! temporary variable
+      integer ierr,lnblnk
+      external lnblnk
+
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+
+       call inichim_readcallphys()
+
+c Dimension test:
+c ---------------
+
+       if (iceparty) then
+         if ((nqchem_min+ncomp+1).ne.nqmx) then
+            print*,'********* Dimension problem! ********'
+            print*,"nqchem_min+ncomp+1).ne.nqmx"
+            print*,"ncomp: ",ncomp
+            print*,"nqchem_min: ",nqchem_min
+            print*,"nqmx: ",nqmx
+            print*,'Change ncomp in chimiedata.h'
+            STOP
+         endif
+       else
+         if ((nqchem_min+ncomp).ne.nqmx) then
+            print*,'********* Dimension problem! ********'
+            print*,"nqchem_min+ncomp).ne.nqmx"
+            print*,"ncomp: ",ncomp
+            print*,"nqchem_min: ",nqchem_min
+            print*,"nqmx: ",nqmx
+            print*,'Change ncomp in chimiedata.h'
+            STOP
+         endif
+       endif
+
+c noms and mmol vectors:
+c ----------------------
+
+       if (iceparty) then
+          do iq=nqchem_min,nqmx-2
+            noms(iq) = nomchem(iq-nqchem_min+1)
+            mmol(iq) = mmolchem(iq-nqchem_min+1)
+          enddo
+          noms(nqmx-1) = 'ice'
+          mmol(nqmx-1) = 18.
+          noms(nqmx)   = 'h2o'
+          mmol(nqmx)   = 18.
+       else
+          do iq=nqchem_min,nqmx-1
+            noms(iq) = nomchem(iq-nqchem_min+1)
+            mmol(iq) = mmolchem(iq-nqchem_min+1)
+          enddo
+          noms(nqmx)   = 'h2o'
+          mmol(nqmx)   = 18.
+       endif
+       if (nqchem_min.gt.1) then
+          do iq=1,nqchem_min-1
+            noms(iq) = 'dust'
+            mmol(iq) = 100.
+          enddo
+       endif
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     co2      =  nqchem_min
+c     co       =  nqchem_min + 1         
+c     o        =  nqchem_min + 2
+c     o(1d)    =  nqchem_min + 3
+c     o2       =  nqchem_min + 4
+c     o3       =  nqchem_min + 5
+c     h        =  nqchem_min + 6
+c     h2       =  nqchem_min + 7
+c     oh       =  nqchem_min + 8
+c     ho2      =  nqchem_min + 9
+c     h2o2     =  nqchem_min + 10
+c     n2       =  nqchem_min + 11
+c     ar       =  nqchem_min + 12
+c     h2o      =  nqmx
+c
+c----------------------------------------------------------------------
+c Major species in files:
+c
+c    1=CO2 
+c    2=AR
+c    3=N2  
+c    4=O2  
+c    5=CO  
+c    6=O   
+c    7=H2
+c
+c Minor species in files:
+c
+c    1=H  
+c    2=OH 
+c    3=HO2 
+c    4=H2O 
+c    5=H2O2 
+c    6=O1D
+c    7=O3
+c
+c----------------------------------------------------------------------
+c Major species:
+        aa(nqchem_min)      = 1
+        aa(nqchem_min + 12) = 2
+        aa(nqchem_min + 11) = 3
+        aa(nqchem_min + 4)  = 4
+        aa(nqchem_min + 1)  = 5
+        aa(nqchem_min + 2)  = 6
+        aa(nqchem_min + 7)  = 7
+c Minor species:
+        aa(nqchem_min + 6)  = 8
+        aa(nqchem_min + 8)  = 9
+        aa(nqchem_min + 9)  = 10
+        aa(nqmx)            = 11
+        aa(nqchem_min + 10) = 12
+        aa(nqchem_min + 3)  = 13 
+        aa(nqchem_min + 5)  = 14
+c----------------------------------------------------------------------
+      open(210, iostat=ierr,file=
+     & datafile(1:lnblnk(datafile))//'/atmosfera_LMD_may.dat')
+      if (ierr.ne.0) then
+        write(*,*)'Error : cannot open file atmosfera_LMD_may.dat '
+        write(*,*)'(in aeronomars/inichim.F)'
+        write(*,*)'It should be in :', datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary atmosfera_LMD_may.dat (and others)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+         STOP
+      endif
+      open(220, iostat=ierr,file=
+     & datafile(1:lnblnk(datafile))//'/atmosfera_LMD_min.dat')
+      if (ierr.ne.0) then
+        write(*,*)'Error : cannot open file atmosfera_LMD_min.dat '
+        write(*,*)'(in aeronomars/inichim.F)'
+        write(*,*)'It should be in :', datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary atmosfera_LMD_min.dat (and others)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+         STOP
+      endif
+
+      read(210,*) tmp
+      read(220,*) tmp
+        do l=1,252
+          read(210,112) tfile(l),zfile(l),nxf(l),(vmrf(l,n),n=1,7)
+          zfile(l)=zfile(l)*100.              !pressure (Pa)
+          sigfile(l)=zfile(l)/zfile(1)       
+        enddo
+        do l=1,252
+          read(220,113)zfilemin(l),(vmrf(l,n),n=8,14)
+          zfilemin(l)=zfilemin(l)*1000.       !height (m)
+          do n=1,14
+            nf(l,n)=vmrf(l,n)*nxf(l)
+          enddo
+        enddo
+        close(210)
+        close(220)
+c flag thermo set to 1 or 0 in newstart 
+c inil=33 for initialisation of thermosphere only        
+c inil=1 for initialisation of all layers        
+        if (thermo.eq.1) then
+        inil=33
+        else
+        inil=1
+        endif
+
+      do i=1,iip1
+       do j=1,jjp1
+         do l=inil,llm
+
+c          zgcm=sig(l)
+          zgcm=sig(l)*ps(i,j)
+          densconc=0.
+          nt=0.
+
+          do n=1,14
+            call intrplf(zgcm,vmrint,zfile,nf(1,n),252)
+c            call intrplf(zgcm,vmrint,sigfile,nf(1,n),252)
+            ni(n)=vmrint
+
+            densconc=densconc+ni(n)*mmolf(n)
+            nt=nt+ni(n)
+          enddo
+
+          mmean=densconc/nt                     ! in amu
+
+          if (nq.ne.nqmx) then
+            do n=nqchem_min,nq-1
+            pq(i,j,l,n)=ni(aa(n))/nt*mmol(n)/mmean
+            if(i.eq.iip1) pq(i,j,l,n)=pq(1,j,l,n) 
+            enddo
+            if (iceparty .and. nq.gt.nqmx-2) then
+              pq(i,j,l,nq) = 0.
+              if(i.eq.iip1) pq(i,j,l,nq)=pq(1,j,l,nq) 
+            else
+              pq(i,j,l,nq)=ni(aa(nq))/nt*mmol(nq)/mmean
+              if(i.eq.iip1) pq(i,j,l,nq)=pq(1,j,l,nq) 
+            endif
+          endif
+          if (nq.eq.nqmx) then
+            do n=nqchem_min,nq-2
+              pq(i,j,l,n)=ni(aa(n))/nt*mmol(n)/mmean
+              if(i.eq.iip1) pq(i,j,l,n)=pq(1,j,l,n) 
+            enddo
+            if (iceparty) then
+              pq(i,j,l,nq-1) = 0.
+              if(i.eq.iip1) pq(i,j,l,nq-1)=pq(1,j,l,nq-1) 
+              pq(i,j,l,nq)=ni(aa(nq))/nt*mmol(nq)/mmean
+              if(i.eq.iip1) pq(i,j,l,nq)=pq(1,j,l,nq) 
+            else
+              do n=nq-1,nq
+                pq(i,j,l,n)=ni(aa(n))/nt*mmol(n)/mmean
+                if(i.eq.iip1) pq(i,j,l,n)=pq(1,j,l,n) 
+              enddo
+            endif
+          endif
+          enddo     !nlayer
+         enddo      !ngrid_j
+        enddo       !ngrid_i
+
+cccccccccccccccccccccccccccccc      
+c  make sure that sum of q = 1      
+c dominent species is = 1 - sum(all other species)      
+cccccccccccccccccccccccccccccc      
+      iqmax=nqchem_min
+      
+      if ((nqmx-nqchem_min).gt.10) then
+       do l=1,llm
+        do j=1,jjp1
+          do i=1,iip1
+           do iq=nqchem_min,nqmx
+            if ( (pq(i,j,l,iq).gt.pq(i,j,l,iqmax)).and.
+     .           (noms(iq).ne."ice") )  then 
+              iqmax=iq
+            endif
+           enddo
+           pq(i,j,l,iqmax)=1.
+           qtot(i,j,l)=0
+           do iq=nqchem_min,nqmx
+            if ( (iq.ne.iqmax).and.
+     .           (noms(iq).ne."ice") ) then        
+              pq(i,j,l,iqmax)=pq(i,j,l,iqmax)-pq(i,j,l,iq)        
+            endif
+           enddo !iq
+           do iq=nqchem_min,nqmx
+            if (noms(iq).ne."ice") then
+             qtot(i,j,l)=qtot(i,j,l)+pq(i,j,l,iq)
+            endif
+c            if (i.eq.1.and.j.eq.1.and.l.eq.1) write(*,*) 'qtot(i,j,l)',
+c     $    qtot(i,j,l)
+           enddo !iq
+            if (i.eq.1.and.j.eq.1) write(*,*) 'qtot(i,j,l)',
+     $    qtot(i,j,l)
+          enddo !i   
+         enddo !j   
+       enddo !l  
+      endif
+ccccccccccccccccccccccccccccccc
+
+66      format(i2,6(1x,e11.5))
+112     format(7x,f7.3,3x,e12.6,3x,e12.6,7(3x,e12.6))
+113     format(1x,f6.2,7(3x,e12.6))
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_readcallphys.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_readcallphys.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inichim_readcallphys.F	(revision 57)
@@ -0,0 +1,462 @@
+      SUBROUTINE inichim_readcallphys
+      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   modified: Sebastien Lebonnois 11/06/2003 (new callphys.def)
+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 "dimphys.h"
+#include "planete.h"
+#include "comcstfi.h"
+#include "comsaison.h"
+#include "comdiurn.h"
+#include "comgeomfi.h"
+#include "callkeys.h"
+#include "surfdat.h"
+
+      character*12 ch1
+      integer ierr
+      logical chem, h2o
+
+
+c --------------------------------------------------------------
+c  Reading the "callphys.def" file controlling some key options
+c --------------------------------------------------------------
+
+      OPEN(99,file='callphys.def',status='old',form='formatted'
+     .     ,iostat=ierr)
+      IF(ierr.EQ.0) THEN
+         PRINT*
+         PRINT*
+         PRINT*,'--------------------------------------------'
+         PRINT*,' Parametres pour la physique (callphys.def)'
+         PRINT*,'--------------------------------------------'
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1 
+         READ(99,*) tracer
+         WRITE(*,8000) ch1,tracer
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') diurnal
+         WRITE(*,8000) ch1,diurnal
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') season
+         WRITE(*,8000) ch1,season
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') lwrite
+         WRITE(*,8000) ch1,lwrite
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callstats
+         WRITE(*,8000) ch1,callstats
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calleofdump
+         WRITE(*,8000) ch1,calleofdump
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*,iostat=ierr) iaervar
+         if(ierr.ne.0) stop'Can t read iaervar in callphys.def (old?)'
+         WRITE(*,8001) ch1,iaervar
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iddist
+         WRITE(*,8001) ch1,iddist
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) topdustref
+         WRITE(*,8002) ch1,topdustref
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callrad
+         WRITE(*,8000) ch1,callrad
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callnlte
+         WRITE(*,8000) ch1,callnlte
+         
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callnirco2
+         WRITE(*,8000) ch1,callnirco2
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calldifv
+         WRITE(*,8000) ch1,calldifv
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calladj
+         WRITE(*,8000) ch1,calladj
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callcond
+         WRITE(*,8000) ch1,callcond
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callsoil
+         WRITE(*,8000) ch1,callsoil
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calllott
+         WRITE(*,8000) ch1,calllott
+
+         READ(99,*) 
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iradia
+         WRITE(*,8001) ch1,iradia
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callg2d
+         WRITE(*,8000) ch1,callg2d
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) rayleigh
+         WRITE(*,8000) ch1,rayleigh
+
+         READ(99,*) 
+         READ(99,*)
+
+c TRACERS:
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) dustbin
+         WRITE(*,8001) ch1,dustbin
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) active
+         WRITE(*,8000) ch1,active
+
+c Test of incompatibility:
+c if active is used, then dustbin should be > 0
+
+         if (active.and.(dustbin.lt.1)) then
+           print*,'if active is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) doubleq
+         WRITE(*,8000) ch1,doubleq
+
+c Test of incompatibility:
+c if doubleq is used, then dustbin should be 1
+
+         if (doubleq.and.(dustbin.ne.1)) then
+           print*,'if doubleq is used, then dustbin should be 1'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) lifting
+         WRITE(*,8000) ch1,lifting
+
+c Test of incompatibility:
+c if lifting is used, then dustbin should be > 0
+
+         if (lifting.and.(dustbin.lt.1)) then
+           print*,'if lifting is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) callddevil
+         WRITE(*,8000) ch1,callddevil
+
+c Test of incompatibility:
+c if dustdevil is used, then dustbin should be > 0
+
+         if (callddevil.and.(dustbin.lt.1)) then
+           print*,'if dustdevil is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) scavenging
+         WRITE(*,8000) ch1,scavenging
+
+c Test of incompatibility:
+c if scavenging is used, then dustbin should be > 0
+
+         if (scavenging.and.(dustbin.lt.1)) then
+           print*,'if scavenging is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) sedimentation
+         WRITE(*,8000) ch1,sedimentation
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iceparty
+         WRITE(*,8000) ch1,iceparty
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) activice
+         WRITE(*,8000) ch1,activice
+
+c Test of incompatibility:
+c if activice is used, then iceparty should be used too
+
+         if (activice.and..not.iceparty) then
+           print*,'if activice is used, iceparty should be used too'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) water
+         WRITE(*,8000) ch1,water
+
+c Test of incompatibility:
+c if iceparty is used, then water should be used too
+
+         if (iceparty.and..not.water) then
+           print*,'if iceparty is used, then water should be used too'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) caps
+         WRITE(*,8000) ch1,caps
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) photochem
+         WRITE(*,8000) ch1,photochem
+
+         READ(99,*)
+         READ(99,*)
+
+c THERMOSPHERE
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callthermos
+         WRITE(*,8000) ch1,callthermos
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') thermoswater
+         WRITE(*,8000) ch1,thermoswater
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callconduct
+         WRITE(*,8000) ch1,callconduct
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calleuv
+         WRITE(*,8000) ch1,calleuv
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callmolvis
+         WRITE(*,8000) ch1,callmolvis
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callmoldiff
+         WRITE(*,8000) ch1,callmoldiff
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') thermochem
+         WRITE(*,8000) ch1,thermochem
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) solarcondate
+         WRITE(*,*) ch1,solarcondate
+
+c Test of incompatibility:
+c if photochem is used, then water should be used too
+
+         if (photochem.and..not.water) then
+           print*,'if photochem is used, water should be used too'
+           stop
+         endif
+
+c if callthermos is used, then thermoswater should be used too 
+c (if water not used already)
+
+         if (callthermos .and. .not.water) then
+           if (callthermos .and. .not.thermoswater) then
+             print*,'if callthermos is used, water or thermoswater 
+     &               should be used too'
+             stop
+           endif
+         endif
+
+         PRINT*,'--------------------------------------------'
+         PRINT*
+         PRINT*
+      ELSE
+         write(*,*)
+         write(*,*) 'Cannot read file callphys.def. Is it here ?'
+         stop
+      ENDIF
+      CLOSE(99)
+
+      pi=2.*asin(1.)
+
+c     managing the tracers, and tests:
+c     -------------------------------
+
+      if(tracer) then
+
+c          when photochem is used, nqchem_min is the rank
+c          of the first chemical species
+
+       if (photochem .or. callthermos) then
+         chem = .true.
+        if (doubleq) then
+          nqchem_min = 3
+        else
+          nqchem_min = dustbin+1
+        end if
+       end if
+
+       if (water .or. thermoswater) h2o = .true.
+
+c          TESTS
+
+       print*,'TRACERS:'
+
+       if ((doubleq).and.(h2o).and.
+     $     (chem).and.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,' 3 to ',nqmx-2,': chemistry'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+       endif
+
+       if ((doubleq).and.(h2o).and.
+     $     (chem).and..not.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,' 3 to ',nqmx-1,': chemistry'
+         print*,nqmx,': water vapor'
+       endif
+
+       if ((doubleq).and.(h2o).and.
+     $     .not.(chem).and.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+         if (nqmx.ne.4) then
+           print*,'nqmx should be 4 with these options...'
+           stop
+         endif
+       endif
+       if ((doubleq).and.(h2o).and.
+     $     .not.(chem).and..not.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,nqmx,': water vapor'
+         if (nqmx.ne.3) then
+           print*,'nqmx should be 3 with these options...'
+           stop
+         endif
+       endif
+
+       if ((doubleq).and..not.(h2o)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         if (nqmx.ne.2) then
+           print*,'nqmx should be 2 with these options...'
+           stop
+         endif
+       endif
+
+       if (.not.(doubleq).and.(h2o).and.
+     $     (chem).and.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqchem_min,' to ',nqmx-2,': chemistry'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     (chem).and..not.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqchem_min,' to ',nqmx-1,': chemistry'
+         print*,nqmx,': water vapor'
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     .not.(chem).and.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+         if (nqmx.ne.(dustbin+2)) then
+           print*,'nqmx should be ',(dustbin+2),
+     $            ' with these options...'
+           stop
+         endif
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     .not.(chem).and..not.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqmx,': water vapor'
+         if (nqmx.ne.(dustbin+1)) then
+           print*,'nqmx should be ',(dustbin+1),
+     $            ' with these options...'
+           stop
+         endif
+       endif
+       if (.not.(doubleq).and..not.(h2o)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+           if (nqmx.ne.dustbin) then
+             print*,'nqmx should be ',dustbin,
+     $              ' with these options...'
+             stop
+           endif
+         else
+           print*,'dustbin=',dustbin,
+     $            ': tracer should be F with these options...'
+           stop
+         endif
+       endif
+
+      endif
+
+8000  FORMAT(t5,a12,l8)
+8001  FORMAT(t5,a12,i8)
+8002  FORMAT(t5,a12,f8.1)
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/init_chimie_B.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/init_chimie_B.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/init_chimie_B.F	(revision 57)
@@ -0,0 +1,85 @@
+      subroutine init_chimie_B
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c   Scheme B
+c
+c   subject:
+c   --------
+c
+c   Initialization of the photochemical scheme
+c
+c   VERSION: 30/04/2003
+c
+c   This is dependent of the chemistry version:
+c   for scheme B its only purpose is reading the
+c   photodissociation rates lookup table
+c
+c   Author:   Franck Lefevre for scheme B
+c
+c   Arguments:
+c   ----------
+c
+c   The output variable is jphot and is put in common chimiedata.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "chimiedata.h"
+#include "datafile.h"
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer fic, ij, iozo, isza, itemp, iz, ierr
+c
+      real xsza
+      integer lnblnk
+      external lnblnk 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      fic = 81
+
+      open(fic, form = 'formatted', status = 'old',
+     $file =datafile(1:lnblnk(datafile))//'/jmars.20030707',iostat=ierr)
+
+      IF (ierr.NE.0) THEN
+        write(*,*)'Error : cannot open file jmars.20030707 '
+        write(*,*)'(in aeronomars/init_chimie_B.F)'
+        write(*,*)'It should be in :',datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary jmars.20030707 (and other datafiles)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+        STOP
+      ENDIF
+
+c
+      print*, 'lecture table des J...'
+c
+      do itemp = 1,ntemp
+         do iozo = 1,nozo
+            do isza = 1,nsza
+               do iz = 200,0,-1
+                  read(fic,*) colairtab(iz), xsza, table_ozo(iozo)
+                  read(fic,*) (jphot(itemp,isza,iz,iozo,ij), ij=1,7)
+                  read(fic,*) (jphot(itemp,isza,iz,iozo,ij), ij=8,11)
+                  do ij = 1,nd
+                     if (jphot(itemp,isza,iz,iozo,ij) .eq. 1.e-30) then
+                        jphot(itemp,isza,iz,iozo,ij) = 0.
+                     end if
+                  end do
+               end do
+            end do
+         end do
+      end do
+c
+      print*, 'lecture table des J...ok'
+      close(fic)
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/interpfast.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/interpfast.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/interpfast.F	(revision 57)
@@ -0,0 +1,29 @@
+      subroutine interpfast(escout,p,nlayer,escin,pin,nl,limdown,limup)
+C
+C subroutine to perform linear interpolation in pressure from 1D profile 
+C escin(nl) sampled on pressure grid pin(nl) to profile
+C escout(nlayer) on pressure grid p(nlayer).
+C
+      real escout(nlayer),p(nlayer)
+      real escin(nl),pin(nl),wm,wp
+      real limup,limdown
+      integer nl,nlayer,n1,n,nm,np
+      nm=1
+      do 5 n1=1,nlayer
+         if(p(n1) .gt. limup .or. p(n1) .lt. limdown) then
+            escout(n1) = 0.0
+         else
+            do n = nm,nl-1
+               if (p(n1).ge.pin(n).and.p(n1).le.pin(n+1)) then
+                  nm=n
+                  np=n+1
+                  wm=abs(pin(nm)-p(n1))/(pin(np)-pin(nm))
+                  wp=1.0 - wm
+                  goto 33
+               endif
+            enddo
+ 33         escout(n1) = escin(np)*wm + escin(nm)*wp
+         endif
+    5 continue
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/intrplf.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/intrplf.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/intrplf.F	(revision 57)
@@ -0,0 +1,42 @@
+c******************************************************
+      SUBROUTINE intrplf(x,y,xd,yd,nd)
+c interpolation, give y = f(x) with array xd,yd known, size nd
+ 
+c  Version with CONSTANT values outside limits
+c**********************************************************
+ 
+c Variable declaration
+c --------------------
+c  Arguments :
+      real x,y
+      real xd(nd),yd(nd)
+      integer nd
+c  internal
+      integer i,j
+      real y_undefined
+ 
+c run
+c ---
+      y_undefined=1.e20
+ 
+      y=0.
+      if ((x.le.xd(1)).and.(x.le.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = yd(1) ! yd(1)
+        if (xd(1).ge.xd(nd)) y = yd(nd) ! yd(1)
+      else if ((x.ge.xd(1)).and.(x.ge.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = yd(nd) ! yd(1)
+        if (xd(1).ge.xd(nd)) y = yd(1) ! yd(1)
+c        y = yd (nd)
+      else
+        do i=1,nd-1
+         if ( ( (x.ge.xd(i)).and.(x.lt.xd(i+1)) )
+     &     .or. ( (x.le.xd(i)).and.(x.gt.xd(i+1)) ) ) then
+           y=yd(i)+(x-xd(i))*(yd(i+1)-yd(i))/(xd(i+1)-xd(i))
+           goto 99
+         end if
+        end do
+      end if
+ 
+ 99   continue
+      return
+      end                    
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inv.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inv.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/inv.F	(revision 57)
@@ -0,0 +1,121 @@
+      SUBROUTINE inv(A,N)
+
+      implicit none
+
+c=======================================================================
+c   Scheme A
+c
+c   subject:
+c   --------
+c
+c   Inversion of a matrix:
+c   Combinaison des routines ludcmp.f et lubksb.f du Numerical Recipes
+c=======================================================================
+
+      real       TINY
+      PARAMETER (TINY=1.0E-20)
+      real       AAMAX,DUM,SUM
+      integer    IMAX,I,II,J,K,L,LL,N
+      real       A(N,N),INDX(N),VV(N,N)
+
+      IMAX = 0
+      do I=1,N
+          AAMAX=0.
+          do J=1,N
+            IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
+          enddo
+          if (AAMAX.EQ.0.) then
+              write(*,*) 'Singular matrix.'
+              stop
+          endif
+          VV(I,1)=1./AAMAX
+      enddo
+      do J=1,N
+        IF (J.GT.1) THEN
+          do I=1,J-1
+            SUM=A(I,J)
+            IF (I.GT.1)THEN
+              do K=1,I-1
+                SUM=SUM-A(I,K)*A(K,J)
+              enddo
+              A(I,J)=SUM
+            ENDIF
+          enddo
+        ENDIF
+        AAMAX=0.
+        do I=J,N
+          SUM=A(I,J)
+          IF (J.GT.1)THEN
+            do K=1,J-1
+              SUM=SUM-A(I,K)*A(K,J)
+            enddo
+            A(I,J)=SUM
+          ENDIF
+          DUM=VV(I,1)*ABS(SUM)
+          IF (DUM.GE.AAMAX) THEN
+            IMAX=I
+            AAMAX=DUM
+          ENDIF
+        enddo
+        IF (J.NE.IMAX)THEN
+          do K=1,N
+            DUM=A(IMAX,K)
+            A(IMAX,K)=A(J,K)
+            A(J,K)=DUM
+          enddo
+          VV(IMAX,1)=VV(J,1)
+        ENDIF
+        INDX(J)=IMAX
+        if(abs(A(J,J)).LT.TINY) then
+              write(*,*) 'Pivot too small.'
+              stop
+        endif
+        IF(J.NE.N)THEN
+          DUM=1./A(J,J)
+          do I=J+1,N
+            A(I,J)=A(I,J)*DUM
+          enddo
+        ENDIF
+      enddo
+
+      do I=1,N
+         do J=1,N
+            VV(I,J) = 0.
+         enddo
+         VV(I,I) = 1.
+      enddo
+
+      do L=1,N
+        II=0
+        do I=1,N
+          LL=INDX(I)
+          SUM=VV(LL,L)
+          VV(LL,L)=VV(I,L)
+          IF (II.NE.0)THEN
+            do J=II,I-1
+              SUM=SUM-A(I,J)*VV(J,L)
+            enddo
+          ELSE IF (SUM.NE.0.) THEN
+            II=I
+          ENDIF
+          VV(I,L)=SUM
+        enddo
+        do I=N,1,-1
+          SUM=VV(I,L)
+          IF(I.LT.N)THEN
+            do J=I+1,N
+              SUM=SUM-A(I,J)*VV(J,L)
+            enddo
+          ENDIF
+          VV(I,L)=SUM/A(I,I)
+        enddo
+      enddo
+
+      do I=1,N
+        do L=1,N
+          A(I,L)=VV(I,L)
+        enddo
+      enddo
+
+      return
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/jthermcalc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/jthermcalc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/jthermcalc.F	(revision 57)
@@ -0,0 +1,557 @@
+c**********************************************************************
+
+      subroutine jthermcalc
+     $ (co2x,o2x,o3px,h2x,h2ox,h2o2x,aux1,aux2,tx,nz,iz,date,zenit)
+
+
+c     feb 2002        fgg           first version
+c     nov 2002        fgg           second version
+c
+c modified from paramhr.F
+c MAC July 2003
+c**********************************************************************
+
+      implicit none
+
+c     common variables and constants
+
+      include 'param.h'
+      include 'param_v3.h'
+
+c    local parameters and variables
+
+      real       xabsi(nabs,nzmax) !densities
+      real       nada
+      real       co2colx2(nzmax,ninter)
+      real       o2colx2(nzmax,ninter)
+      real       o3pcolx2(nzmax,ninter)
+      real       co2colx(nzmax)              !column density of CO2 (cm^-2)
+      real       o2colx(nzmax)               !column density of O2(cm^-2)
+      real       o3pcolx(nzmax)              !column density of O(3P)(cm^-2)
+      real       h2o2colx(nzmax)             !column density of H2O2(cm^-2)
+      real       t2(nzmax)
+      real       coltemp(nzmax)
+      real       dt(nzmax)
+      real       sigma(ninter,nzmax)
+      real       alfa(ninter,nzmax)
+      real       xx
+      real       grav(nzmax)
+      
+      integer    i,j,k,icol,indexint          !indexes
+      character  dn
+
+c     input and output variables
+
+      integer    nz                          !number of layers
+      real       co2x(nz)                    !density of CO2(cm^-3)
+      real       o2x(nz)                     !density of O2(cm^-3)
+      real       o3px(nz)                    !density of O(3P)(cm^-3)
+      real       h2x(nz)                     !density of H2(cm^-3)
+      real       h2ox(nz)                    !density of H2O(cm^-3)
+      real       h2o2x(nz)                   !density of H2O2(cm^-3)
+      real       aux1(nz)	             !auxiliar variable
+      real       aux2(nz)                    !auxiliar variable
+      real       tx(nz)                      !temperature
+      real       date
+      real       zenit
+      real       iz(nz)
+
+
+c     variables used in interpolation
+
+      real aux3(nz2), aux4(nz2)
+                                              !auxiliar variables
+      real       limdown                      !limits for interpolation
+      real       limup                        !        ""
+
+c*************************PROGRAM STARTS*******************************
+
+      if(zenit.gt.100.) then
+         dn='n'
+         else
+         dn='d'
+      end if
+      if(dn.eq.'n') then
+        return
+      endif 
+     
+      do i=1,nz
+         xabsi(1,i) = co2x(i)
+         xabsi(2,i) = o2x(i)
+         xabsi(3,i) = o3px(i)
+         xabsi(4,i) = h2ox(i)
+         xabsi(5,i) = h2x(i)
+         xabsi(6,i) = h2o2x(i)
+      end do
+
+      do i=1,nz
+         t2(i)=tx(i)
+         if(t0(i).lt.195.0) t0(i)=195.0
+         if(t0(i).gt.295.0) t0(i)=295.0
+         if(t2(i).lt.195.0) t2(i)=195.0
+         if(t2(i).gt.295.0) t2(i)=295.0
+      end do
+
+
+c    COLUMN CALCULATION 
+
+      call column(co2x,o2x,o3px,h2x,h2ox,h2o2x,tx,nz,iz,zenit,co2colx
+     $,o2colx,o3pcolx,h2o2colx)
+
+      coltemp(nz)=co2colx(nz)*abs(t2(nz)-t0(nz))
+      dt(nz)=coltemp(nz)/co2colx(nz)
+      do i=nz-1,1,-1
+        coltemp(i)=coltemp(i+1)+ 
+     $         ( co2x(i) + co2x(i+1) ) * 0.5 
+     $         * 1e5 * (iz(i+1)-iz(i)) * abs(t2(i)-t0(i))
+        dt(i)=coltemp(i)/co2colx(i)
+      end do
+
+
+c     Calculo la seccion eficaz de CO2 a la temperatura t0 a cada altura
+c CALCULATION OF CO2 CROSS-SECTION AT TEMPERATURE T0 AT EACH HEIGHT
+
+      do i=1,nz
+         do indexint=24,32
+           sigma(indexint,i)=co2crsc195(indexint-23)*
+     $         (1+((co2crsc295(indexint-23)/co2crsc195(indexint-23))-1.)
+     $         *(t0(i)-195.)/100.)
+           if(t0(i).ne.295.) then
+             alfa(indexint,i)=((co2crsc295(indexint-23)
+     $                        /sigma(indexint,i))-1.)/(295.-t0(i))
+           else 
+             alfa(indexint,i)=0.
+           end if
+         end do
+      end do
+
+
+c     Comienza la interpolacion
+c INTERPOLATION BEGINS
+c************************************************
+c     o2,0.1,5.0
+c************************************************
+      
+      indexint=1
+      limdown=1e-20
+      limup=1e26
+       do i=1,nz
+         aux2(nz-i+1) = o2colx(i) + o3pcolx(i)
+       end do
+       do i=1,nz2
+         aux3(i) = jabsifotsint(indexint,2,nz2-i+1)
+         aux4(i) = c23(nz2-i+1)
+       enddo
+       call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup)
+       do i=1,nz
+         jfotsout(indexint,2,i) = aux1(nz-i+1)
+       enddo
+
+c************************************************
+c     o3p,0.1,5.0
+c************************************************
+
+      indexint=1
+      limdown=1e-20
+      limup=1e26
+         do i=1,nz
+            aux2(nz-i+1) = o2colx(i) + o3pcolx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,3,nz2-i+1)
+            aux4(i) = c23(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup)
+         do i=1,nz
+            jfotsout(indexint,3,i) = aux1(nz-i+1)
+         enddo
+
+
+c************************************************
+c     h2,0.1,5.0
+c************************************************
+
+      indexint=1
+      limdown=1e-20
+      limup=1e26
+         do i=1,nz
+            aux2(nz-i+1) = o2colx(i) + o3pcolx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,5,nz2-i+1)
+            aux4(i) = c23(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,5,i) = aux1(nz-i+1)
+         enddo
+
+
+c************************************************
+c     interpola para el o2 entre 5 y 90.8nm
+c************************************************
+
+      limdown=1e-20
+      limup=1e12
+      do indexint=2,16
+         co2colx2(nz,indexint)= co2colx(nz) 
+     $              * crscabsi2(1,indexint)
+         o2colx2(nz,indexint)= o2colx(nz) 
+     $              * crscabsi2(2,indexint)
+         o3pcolx2(nz,indexint)= o3pcolx(nz) 
+     $              * crscabsi2(3,indexint)
+         do i=nz-1,1,-1
+            co2colx2(i,indexint) = co2colx2(i+1,indexint) + 
+     $         ( xabsi(1,i) + xabsi(1,i+1) ) * 0.5 
+     $           * 1e5 * (iz(i+1)-iz(i)) * crscabsi2(1,indexint)
+            o2colx2(i,indexint) = o2colx2(i+1,indexint) + 
+     $         ( xabsi(2,i) + xabsi(2,i+1) ) * 0.5 
+     $         * 1e5 * (iz(i+1)-iz(i)) * crscabsi2(2,indexint)
+            o3pcolx2(i,indexint) = o3pcolx2(i+1,indexint) + 
+     $         ( xabsi(3,i) + xabsi(3,i+1) ) * 0.5 
+     $         * 1e5 * (iz(i+1)-iz(i)) * crscabsi2(3,indexint)
+         end do
+         do i=1,nz
+            aux2(nz-i+1) = co2colx2(i,indexint)+
+     $      o2colx2(i,indexint)+
+     $      o3pcolx2(i,indexint)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,2,nz2-i+1)
+            aux4(i) = c123(indexint,nz2-i+1)
+         enddo
+          call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+          do i=1,nz
+            jfotsout(indexint,2,i) = aux1(nz-i+1) 
+          enddo
+      end do
+      
+
+c************************************************
+c     idem para o3p entre 5 y 90.8nm
+c************************************************
+
+      do indexint=2,16
+         do i=1,nz
+            aux2(nz-i+1) = co2colx2(i,indexint) +
+     $      o2colx2(i,indexint) +
+     $      o3pcolx2(i,indexint)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,3,nz2-i+1)
+            aux4(i) = c123(indexint,nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,3,i) = aux1(nz-i+1)
+         enddo
+      end do
+
+
+c************************************************
+c     idem para co2 entre 5 y 90.8nm
+c************************************************
+
+      do indexint=2,16
+         do i=1,nz
+            aux2(nz-i+1) = co2colx2(i,indexint) +
+     $      o2colx2(i,indexint) +
+     $      o3pcolx2(i,indexint)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,1,nz2-i+1)
+            aux4(i) = c123(indexint,nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,1,i) = aux1(nz-i+1)
+         enddo
+      end do
+
+
+c************************************************
+c     idem para h2 entre 5 y 80.6nm
+c************************************************
+
+      do indexint=2,15
+         do i=1,nz
+            aux2(nz-i+1) = co2colx2(i,indexint) +
+     $      o2colx2(i,indexint) +
+     $      o3pcolx2(i,indexint)
+         end do
+         do i=1,nabs
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,5,nz2-i+1)
+            aux4(i) = c123(indexint,nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,5,i) = aux1(nz-i+1)
+         enddo
+      end do
+
+
+c************************************************
+c      co2,90.9,119.5
+c************************************************
+
+      limdown=1e-20
+      limup=1e26
+      do indexint=17,24
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i) + o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,1,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+c           print*,indexint,i,aux2(i),aux1(i),aux3(i),aux4(i)
+           jfotsout(indexint,1,i) = aux1(nz-i+1)
+           if(indexint.eq.24) then
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+             jfotsout(indexint,1,i) = aux1(nz-i+1)
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))*
+     $           (1+alfa(indexint,i)*(t2(i)-t0(i)))
+           else 
+             jfotsout(indexint,1,i)=0.
+           end if
+           end if
+c           print*,indexint,i,(jfotsout(indexint,j,i),j=1,nabs)
+         enddo
+      end do
+
+
+c************************************************
+c     o2,90.9,119.5
+c************************************************
+      
+      do indexint=17,24
+         do i=1,nz
+            aux2(nz-i+1) = o2colx(i) + co2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,2,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,2,i) = aux1(nz-i+1)
+            if(indexint.eq.24) then
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+               jfotsout(indexint,2,i) = aux1(nz-i+1)
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))
+               else
+                  jfotsout(indexint,2,i)=0.
+               end if
+            end if
+         enddo
+      end do
+
+
+c************************************************
+c      co2,119.6,202.5
+c************************************************
+
+      do indexint=25,31
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i) + o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,1,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+               jfotsout(indexint,1,i) = aux1(nz-i+1)
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))*
+     $           (1+alfa(indexint,i)*(t2(i)-t0(i)))
+            else
+               jfotsout(indexint,1,i) = 0.
+            end if
+         enddo
+      end do
+
+
+c************************************************
+c      o2,119.6,202.5
+c************************************************
+
+      do indexint=25,31
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i) + o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,2,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+            jfotsout(indexint,2,i) = aux1(nz-i+1)
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))
+            else
+               jfotsout(indexint,2,i)=0.
+            end if
+         enddo
+      end do
+
+
+c************************************************
+c      h2o,119.6,202.5
+c************************************************
+
+      do indexint=25,31
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i) + o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,4,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+            jfotsout(indexint,4,i) = aux1(nz-i+1) 
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))
+            else
+               jfotsout(indexint,4,i) = 0.
+            end if
+         enddo
+      end do
+
+
+c************************************************
+c      h2o2,119.6,202.5
+c************************************************
+
+      do indexint=25,31
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i) + o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,6,nz2-i+1)
+            aux4(i) = c12(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+            jfotsout(indexint,6,i) = aux1(nz-i+1) 
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))
+            else
+               jfotsout(indexint,6,i) = 0.
+            end if
+         enddo
+      end do
+
+
+c************************************************
+c     co2,202.6,210.0
+c************************************************
+
+      indexint=32
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,1,nz2-i+1)
+            aux4(i) = c1(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+               jfotsout(indexint,1,i) = aux1(nz-i+1)
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))*
+     $           (1+alfa(indexint,i)*(t2(i)-t0(i)))
+            else
+               jfotsout(indexint,1,i)=0.
+            end if
+         enddo
+
+
+c************************************************
+c     h2o2,202.6,210.0
+c************************************************
+
+      indexint=32
+         do i=1,nz
+            aux2(nz-i+1) = co2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,6,nz2-i+1)
+            aux4(i) = c1(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+           if(sigma(indexint,i)*alfa(indexint,i)*coltemp(i).lt.60.) then
+            jfotsout(indexint,6,i) = aux1(nz-i+1) 
+     $            *exp(-sigma(indexint,i)*alfa(indexint,i)*coltemp(i))
+            else
+               jfotsout(indexint,6,i)=0.
+            end if
+         enddo
+
+
+c************************************************
+c     h2o2,210.1,337.5
+c************************************************
+
+      indexint=33
+      limdown=1.e-20
+      limup=1e25
+         do i=1,nz
+            aux2(nz-i+1) = h2o2colx(i)
+         end do
+         do i=1,nz2
+            aux3(i) = jabsifotsint(indexint,6,nz2-i+1)
+            aux4(i) = ch2o2(nz2-i+1)
+         enddo
+         call interpfast 
+     $        ( aux1, aux2, nz,  aux3, aux4, nz2 , limdown , limup )
+         do i=1,nz
+            jfotsout(indexint,6,i) = aux1(nz-i+1)
+         enddo
+
+      return
+
+      end
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiff.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiff.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiff.F	(revision 57)
@@ -0,0 +1,540 @@
+      subroutine moldiff(pplay,pplev,pt,pdt,pq,pdq,ptimestep,
+     &                   zzlay,pdteuv,pdtconduc,pdqdiff)
+
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "conc.h"
+
+
+c
+c Input/Output
+c
+      real ptimestep
+      real pplay(ngridmx,nlayermx)
+      real zzlay(ngridmx,nlayermx)
+      real pplev(ngridmx,nlayermx+1)
+      real pq(ngridmx,nlayermx,nqmx)
+      real pdq(ngridmx,nlayermx,nqmx)
+      real pt(ngridmx,nlayermx)
+      real pdt(ngridmx,nlayermx)
+      real pdteuv(ngridmx,nlayermx)
+      real pdtconduc(ngridmx,nlayermx)
+      real pdqdiff(ngridmx,nlayermx,nqmx)
+c
+c Local
+c
+       real hco2(ncomptot),ho
+
+      integer ig,nz,l,n,nn
+      real del1,del2, tmean ,dalfinvdz, d
+      real hh,dcoef,dcoef1,ptfac, ntot, dens, dens2, dens3
+      real hp(nlayermx)
+      real tt(nlayermx)
+      real qq(nlayermx,ncomptot)
+      real dmmeandz(nlayermx)
+      real qnew(nlayermx,ncomptot)
+      real zlocal(nlayermx)
+      real alf(ncomptot-1,ncomptot-1)
+      real alfinv(nlayermx,ncomptot-1,ncomptot-1)
+      real indx(ncomptot-1)
+      real b(nlayermx,ncomptot-1)
+      real y(ncomptot-1,ncomptot-1)
+      real aa(nlayermx,ncomptot-1,ncomptot-1)
+      real bb(nlayermx,ncomptot-1,ncomptot-1)
+      real cc(nlayermx,ncomptot-1,ncomptot-1)
+      real atri(nlayermx-2)
+      real btri(nlayermx-2)
+      real ctri(nlayermx-2)
+      real rtri(nlayermx-2)
+      real qtri(nlayermx-2)
+      real alfdiag(ncomptot-1)
+      real wi(ncomptot), flux(ncomptot), pote
+
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2,
+     $        i_o1d, i_o, i_h, i_oh, i_ho2, i_n2, i_o3, i_ar
+      integer g_co2, g_co, g_o2, g_h2, g_h2o, g_h2o2,
+     $        g_o1d, g_o, g_h, g_oh, g_ho2, g_o3, g_n2, g_ar
+      integer gcmind(ncomptot)
+      integer ierr
+
+      logical firstcall
+      real abfac(ncomptot)
+      real dij(ncomptot,ncomptot)
+      save firstcall
+      save dij
+      data firstcall /.true./
+
+      if (firstcall) then
+        call moldiffcoeff(dij)
+        print*,'MOLDIFF  EXO'
+        firstcall= .false.
+      endif
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      g_co2      =  nqchem_min
+      g_co       =  nqchem_min + 1
+      g_o        =  nqchem_min + 2
+      g_o1d      =  nqchem_min + 3
+      g_o2       =  nqchem_min + 4
+      g_o3       =  nqchem_min + 5
+      g_h        =  nqchem_min + 6
+      g_h2       =  nqchem_min + 7
+      g_oh       =  nqchem_min + 8
+      g_ho2      =  nqchem_min + 9
+      g_h2o2     =  nqchem_min + 10
+      g_n2       =  nqchem_min + 11
+      g_ar       =  nqchem_min + 12
+      g_h2o      =  nqmx
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the molecular diffusion
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c  Atomic oxygen must always be the LAST species of the list as
+c it is the dominant species at high altitudes. 
+
+      i_co   = 1
+      i_n2   = 2
+      i_o2   = 3
+      i_co2  = 4
+      i_h2   = 5
+      i_h    = 6
+      i_oh   = 7
+      i_ho2  = 8
+      i_h2o  = 9
+      i_h2o2 = 10
+      i_o1d  = 11
+      i_o3   = 12
+      i_ar   = 13
+      i_o    = 14
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     array to relate local indexes to gcm indexes
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      gcmind(i_co)	=	g_co
+      gcmind(i_n2)	=	g_n2
+      gcmind(i_o2)	=	g_o2
+      gcmind(i_co2)	=	g_co2
+      gcmind(i_h2)	=	g_h2
+      gcmind(i_h)	=	g_h
+      gcmind(i_oh)	=	g_oh
+      gcmind(i_ho2)	=	g_ho2
+      gcmind(i_h2o)	=	g_h2o
+      gcmind(i_h2o2)=	g_h2o2
+      gcmind(i_o1d) =	g_o1d
+      gcmind(i_o3)  =	g_o3
+      gcmind(i_o)   =	g_o
+      gcmind(i_ar)   =	g_ar
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      nz=nlayermx
+
+      do ig=1,ngridmx
+
+        do l=2,nz-1
+          tt(l)=pt(ig,l)+pdt(ig,l)*ptimestep
+     &                  +pdteuv(ig,l)*ptimestep
+     &                  +pdtconduc(ig,l)*ptimestep
+
+          do nn=1,ncomptot
+            qq(l,nn)=pq(ig,l,gcmind(nn))+pdq(ig,l,gcmind(nn))*ptimestep
+            qq(l,nn)=max(qq(l,nn),1.e-30)
+          enddo
+          hp(l)=-log(pplay(ig,l+1)/pplay(ig,l-1))
+          dmmeandz(l)=(mmean(ig,l+1)-mmean(ig,l-1))/hp(l)
+        enddo
+
+        tt(1)=pt(ig,1)  +pdt(ig,1)*ptimestep
+     &                  +pdteuv(ig,1)*ptimestep
+     &                  +pdtconduc(ig,1)*ptimestep
+        tt(nz)=pt(ig,nz)+pdt(ig,nz)*ptimestep
+     &                  +pdteuv(ig,nz)*ptimestep
+     &                  +pdtconduc(ig,nz)*ptimestep
+
+        do nn=1,ncomptot
+          qq(1,nn)=pq(ig,1,gcmind(nn))+pdq(ig,1,gcmind(nn))*ptimestep
+          qq(nz,nn)=pq(ig,nz,gcmind(nn))+pdq(ig,nz,gcmind(nn))*ptimestep
+          qq(1,nn)=max(qq(1,nn),1.e-30)
+          qq(nz,nn)=max(qq(nz,nn),1.e-30)
+        enddo
+        hp(1)=-log(pplay(ig,2)/pplay(ig,1))
+        dmmeandz(1)=(-3.*mmean(ig,1)+4.*mmean(ig,2)
+     &               -mmean(ig,3))/(2.*hp(1))
+        hp(nz)=-log(pplay(ig,nz)/pplay(ig,nz-1))
+        dmmeandz(nz)=(3.*mmean(ig,nz)-4.*mmean(ig,nz-1)
+     &                +mmean(ig,nz-2))/(2.*hp(nz))
+c
+c Setting-up matrix of alfa coefficients from Dickinson and Ridley 1972
+c
+      do l=1,nz
+       if(abs(dmmeandz(l)) .lt. 1.e-5) dmmeandz(l)=0.0
+        hh=rnew(ig,l)*tt(l)/g
+        ptfac=(1.e5/pplay(ig,l))*(tt(l)/273)**1.75
+        ntot=pplay(ig,l)/(1.381e-23*tt(l))      		! in #/m3
+
+        do nn=1,ncomptot-1            ! rows
+          alfdiag(nn)=0.
+          dcoef1=dij(nn,i_o)*ptfac
+          do n=1,ncomptot-1           ! columns
+            y(nn,n)=0.
+            dcoef=dij(nn,n)*ptfac
+            alf(nn,n)=qq(l,nn)/ntot/1.66e-27
+     &         *(1./(mmol(gcmind(n))*dcoef)-1./(mmol(g_o)*dcoef1))
+            alfdiag(nn)=alfdiag(nn)
+     &       +(1./(mmol(gcmind(n))*dcoef)-1./(mmol(g_o)*dcoef1))
+     &        *qq(l,n)
+          enddo
+          dcoef=dij(nn,nn)*ptfac
+          alfdiag(nn)=alfdiag(nn)
+     &       -(1./(mmol(gcmind(nn))*dcoef)-1./(mmol(g_o)*dcoef1))
+     &          *qq(l,nn)
+          alf(nn,nn)=-(alfdiag(nn)
+     &                 +1./(mmol(g_o)*dcoef1))/ntot/1.66e-27
+          y(nn,nn)=1.
+          b(l,nn)=-(dmmeandz(l)/mmean(ig,l)
+     &              +mmol(gcmind(nn))/mmean(ig,l)-1.)
+        enddo
+
+c
+c Inverting the alfa matrix
+c
+        call ludcmp(alf,ncomptot-1,ncomptot-1,indx,d,ierr)
+
+c       TEMPORAIRE *****************************
+        if (ierr.ne.0) then
+            write(*,*) 'In moldiff: Problem in LUDCMP with matrix alf'
+            write(*,*) 'Singular matrix ?'
+c           write(*,*) 'Matrix alf = ', alf
+            write(*,*) 'ig, l=',ig, l
+            write(*,*) 'No molecular diffusion this time !'
+            call zerophys(ngridmx*nlayermx*nqmx,pdqdiff)
+            return
+c           stop
+        end if
+c       *******************************************
+        do n=1,ncomptot-1
+          call lubksb(alf,ncomptot-1,ncomptot-1,indx,y(1,n))
+          do nn=1,ncomptot-1
+            alfinv(l,nn,n)=y(nn,n)/hh
+          enddo
+        enddo
+      enddo
+
+c
+c Calculating coefficients of the system
+c
+
+c      zlocal(1)=-log(pplay(ig,1)/pplev(ig,1))* Rnew(ig,1)*tt(1)/g
+      zlocal(1)=zzlay(ig,1)
+
+      do l=2,nz-1
+        del1=hp(l)*pplay(ig,l)/(g*ptimestep)
+        del2=(hp(l)/2)**2*pplay(ig,l)/(g*ptimestep)
+        do nn=1,ncomptot-1
+          do n=1,ncomptot-1
+            dalfinvdz=(alfinv(l+1,nn,n)-alfinv(l-1,nn,n))/hp(l)
+            aa(l,nn,n)=-dalfinvdz/del1+alfinv(l,nn,n)/del2
+     &                +alfinv(l-1,nn,n)*b(l-1,n)/del1    
+            bb(l,nn,n)=-2.*alfinv(l,nn,n)/del2
+            cc(l,nn,n)=dalfinvdz/del1+alfinv(l,nn,n)/del2
+     &                -alfinv(l+1,nn,n)*b(l+1,n)/del1    
+          enddo
+        enddo
+
+c        tmean=tt(l)
+c        if(tt(l).ne.tt(l-1))
+c     &        tmean=(tt(l)-tt(l-1))/log(tt(l)/tt(l-1))
+c        zlocal(l)= zlocal(l-1)
+c     &         -log(pplay(ig,l)/pplay(ig,l-1))*rnew(ig,l)*tmean/g
+      zlocal(l)=zzlay(ig,l)
+      enddo 
+
+c      zlocal(nz)= zlocal(nz-1)
+c     &         -log(pplay(ig,nz)/pplay(ig,nz-1))*rnew(ig,nz)*tmean/g
+      zlocal(nz)=zzlay(ig,nz)
+        
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Escape velocity from Jeans equation for the flux of H and H2
+c (Hunten 1973, eq. 5)
+      
+      do n=1,ncomptot
+        wi(n)=1.
+        flux(n)=0.
+        abfac(n)=1.
+      enddo
+
+       dens=pplay(ig,nz)/(rnew(ig,nz)*tt(nz))
+c
+c For H:
+c
+       pote=(3398000.+zlocal(nz))/
+     &         (1.381e-23*tt(nz)/(1.6605e-27*mmol(g_h)*g))
+       wi(i_h)=sqrt(2.*1.381e-23*tt(nz)/(1.6605e-27*mmol(g_h)))
+     &             /(2.*sqrt(3.1415))*(1.+pote)*exp(-pote)
+       flux(i_h)=qq(nz,i_h)*dens/(1.6605e-27*mmol(g_h))*wi(i_h)
+       flux(i_h)=flux(i_h)*1.6606e-27
+       abfac(i_h)=0.
+c
+c For H2:
+c
+       pote=(3398000.+zlocal(nz))/
+     &         (1.381e-23*tt(nz)/(1.6605e-27*mmol(g_h2)*g))
+       wi(i_h2)=sqrt(2.*1.381e-23*tt(nz)/(1.6605e-27*mmol(g_h2)))
+     &              /(2.*sqrt(3.1415))*(1.+pote)*exp(-pote)
+       flux(i_h2)=qq(nz,i_h2)*dens/(1.6605e-27*mmol(g_h2))*wi(i_h2)
+       flux(i_h2)=flux(i_h2)*1.6606e-27
+       abfac(i_h2)=0.
+
+c ********* TEMPORAIRE : no escape for h and h2
+c     do n=1,ncomptot
+c       wi(n)=1.
+c       flux(n)=0.
+c       abfac(n)=1.
+c     enddo
+c ********************************************
+
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+c
+c Setting coefficients for tridiagonal matrix and solving the system
+c
+
+      do nn=1,ncomptot-1
+        do l=2,nz-1
+          atri(l-1)=aa(l,nn,nn)
+          btri(l-1)=bb(l,nn,nn)+1.
+          ctri(l-1)=cc(l,nn,nn)
+          rtri(l-1)=qq(l,nn)
+          do n=1,ncomptot-1
+            rtri(l-1)=rtri(l-1)-(aa(l,nn,n)*qq(l-1,n)
+     &                           +bb(l,nn,n)*qq(l,n)
+     &                           +cc(l,nn,n)*qq(l+1,n))
+          enddo
+          rtri(l-1)=rtri(l-1)+(aa(l,nn,nn)*qq(l-1,nn)
+     &                         +bb(l,nn,nn)*qq(l,nn)
+     &                         +cc(l,nn,nn)*qq(l+1,nn))
+        enddo
+
+c
+c Boundary conditions:
+c	Escape flux for H and H2 at top
+c	Diffusive equilibrium for the other species at top
+c	Perfect mixing for all at bottom
+c
+
+        rtri(nz-2)=rtri(nz-2)
+     &             -ctri(nz-2)*flux(nn)*mmol(gcmind(nn))/(dens*wi(nn))
+
+        atri(nz-2)=atri(nz-2)
+     &             -abfac(nn)*ctri(nz-2)/(3.-2.*hp(nz)*b(nz,nn))
+        btri(nz-2)=btri(nz-2)
+     &             +abfac(nn)*4.*ctri(nz-2)/(3.-2.*hp(nz)*b(nz,nn))
+
+c        rtri(1)=rtri(1)-atri(1)*qq(1,nn)
+        btri(1)=btri(1)+atri(1)
+
+        call tridag(atri,btri,ctri,rtri,qtri,nz-2)
+
+        do l=2,nz-1
+c          qnew(l,nn)=qtri(l-1)
+          qnew(l,nn)=max(qtri(l-1),1.e-30)
+        enddo
+
+        qnew(nz,nn)=flux(nn)*mmol(gcmind(nn))/(dens*wi(nn))
+     &               +abfac(nn)*(4.*qnew(nz-1,nn)-qnew(nz-2,nn))
+     &                /(3.-2.*hp(nz)*b(nz,nn))
+c        qnew(1,nn)=qq(1,nn)
+        qnew(1,nn)=qnew(2,nn)
+         
+        qnew(nz,nn)=max(qnew(nz,nn),1.e-30)
+        qnew(1,nn)=max(qnew(1,nn),1.e-30)
+
+      enddo 	! loop on species
+
+      DO l=1,nz
+        if(zlocal(l).gt.65000.)then
+        pdqdiff(ig,l,g_o)=0.
+        do n=1,ncomptot-1
+          pdqdiff(ig,l,gcmind(n))=(qnew(l,n)-qq(l,n))
+          pdqdiff(ig,l,g_o)=pdqdiff(ig,l,g_o)-(qnew(l,n)-qq(l,n))
+          pdqdiff(ig,l,gcmind(n))=pdqdiff(ig,l,gcmind(n))/ptimestep
+        enddo
+		pdqdiff(ig,l,g_o)=pdqdiff(ig,l,g_o)/ptimestep
+        endif
+      ENDDO
+
+c      do l=2,nz
+c        do n=1,ncomptot-1
+c          hco2(n)=qnew(l,n)*pplay(ig,l)/(rnew(ig,l)*tt(l)) /
+c     &      (qnew(l-1,n)*pplay(ig,l-1)/(rnew(ig,l-1)*tt(l-1))) 
+c          hco2(n)=-(zlocal(l)-zlocal(l-1))/log(hco2(n))/1000.
+c        enddo
+c        write(225,*),l,pt(1,l),(hco2(n),n=1,6)
+c        write(226,*),l,pt(1,l),(hco2(n),n=7,12)
+c      enddo
+
+      enddo		! ig loop
+
+      return
+      end
+
+c    ********************************************************************
+c    ********************************************************************
+c    ********************************************************************
+ 
+      subroutine tridag(a,b,c,r,u,n)
+      parameter (nmax=100)
+c      dimension gam(nmax),a(n),b(n),c(n),r(n),u(n)
+      real gam(nmax),a(n),b(n),c(n),r(n),u(n)
+      if(b(1).eq.0.)pause
+      bet=b(1)
+      u(1)=r(1)/bet
+      do 11 j=2,n
+        gam(j)=c(j-1)/bet
+        bet=b(j)-a(j)*gam(j)
+        if(bet.eq.0.)pause
+        u(j)=(r(j)-a(j)*u(j-1))/bet
+11    continue
+      do 12 j=n-1,1,-1
+        u(j)=u(j)-gam(j+1)*u(j+1)
+12    continue
+      return
+      end
+
+c    ********************************************************************
+c    ********************************************************************
+c    ********************************************************************
+
+      SUBROUTINE LUBKSB(A,N,NP,INDX,B)
+
+      implicit none
+
+      integer i,j,n,np,ii,ll
+      real sum
+      real a(np,np),indx(np),b(np)
+
+c      DIMENSION A(NP,NP),INDX(N),B(N)
+      II=0
+      DO 12 I=1,N
+        LL=INDX(I)
+        SUM=B(LL)
+        B(LL)=B(I)
+        IF (II.NE.0)THEN
+          DO 11 J=II,I-1
+            SUM=SUM-A(I,J)*B(J)
+11        CONTINUE
+        ELSE IF (SUM.NE.0.) THEN
+          II=I
+        ENDIF
+        B(I)=SUM
+12    CONTINUE
+      DO 14 I=N,1,-1
+        SUM=B(I)
+        IF(I.LT.N)THEN
+          DO 13 J=I+1,N
+            SUM=SUM-A(I,J)*B(J)
+13        CONTINUE
+        ENDIF
+        B(I)=SUM/A(I,I)
+14    CONTINUE
+      RETURN
+      END
+
+c    ********************************************************************
+c    ********************************************************************
+c    ********************************************************************
+
+      SUBROUTINE LUDCMP(A,N,NP,INDX,D,ierr)
+
+      implicit none
+
+      integer n,np,nmax,i,j,k,imax
+      real d,tiny,aamax
+      real a(np,np),indx(np)
+      integer ierr  ! error =0 if OK, =1 if problem
+
+      PARAMETER (NMAX=100,TINY=1.0E-20)
+c      DIMENSION A(NP,NP),INDX(N),VV(NMAX)
+      real sum,vv(nmax),dum
+
+      D=1.
+      DO 12 I=1,N
+        AAMAX=0.
+        DO 11 J=1,N
+          IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
+11      CONTINUE
+        IF (AAMAX.EQ.0.) then
+            write(*,*) 'In moldiff: Problem in LUDCMP with matrix A'
+            write(*,*) 'Singular matrix ?'
+c           write(*,*) 'Matrix A = ', A
+c           TO DEBUG :
+            ierr =1
+            return
+c           stop
+        END IF 
+
+        VV(I)=1./AAMAX
+12    CONTINUE
+      DO 19 J=1,N
+        IF (J.GT.1) THEN
+          DO 14 I=1,J-1
+            SUM=A(I,J)
+            IF (I.GT.1)THEN
+              DO 13 K=1,I-1
+                SUM=SUM-A(I,K)*A(K,J)
+13            CONTINUE
+              A(I,J)=SUM
+            ENDIF
+14        CONTINUE
+        ENDIF
+        AAMAX=0.
+        DO 16 I=J,N
+          SUM=A(I,J)
+          IF (J.GT.1)THEN
+            DO 15 K=1,J-1
+              SUM=SUM-A(I,K)*A(K,J)
+15          CONTINUE
+            A(I,J)=SUM
+          ENDIF
+          DUM=VV(I)*ABS(SUM)
+          IF (DUM.GE.AAMAX) THEN
+            IMAX=I
+            AAMAX=DUM
+          ENDIF
+16      CONTINUE
+        IF (J.NE.IMAX)THEN
+          DO 17 K=1,N
+            DUM=A(IMAX,K)
+            A(IMAX,K)=A(J,K)
+            A(J,K)=DUM
+17        CONTINUE
+          D=-D
+          VV(IMAX)=VV(J)
+        ENDIF
+        INDX(J)=IMAX
+        IF(J.NE.N)THEN
+          IF(A(J,J).EQ.0.)A(J,J)=TINY
+          DUM=1./A(J,J)
+          DO 18 I=J+1,N
+            A(I,J)=A(I,J)*DUM
+18        CONTINUE
+        ENDIF
+19    CONTINUE
+      IF(A(N,N).EQ.0.)A(N,N)=TINY
+      ierr =0
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiffcoeff.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiffcoeff.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/moldiffcoeff.F	(revision 57)
@@ -0,0 +1,143 @@
+      subroutine moldiffcoeff(dij)
+
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing molecular diffusion coefficients
+c   following Nair 94 (pg 131)
+c   author:  MAC 2002
+c   ------
+c
+c=======================================================================
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "conc.h"
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER nq, n, nn, i
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2, i_n2, i_o3,
+     $        i_o1d, i_o, i_h, i_oh, i_ho2, i_ar
+      integer g_co2, g_co, g_o2, g_h2, g_h2o, g_h2o2,
+     $        g_o1d, g_o, g_h, g_oh, g_ho2, g_o3, g_n2, g_ar
+      integer gcmind(ncomptot)
+
+      real dnh
+      real dij(ncomptot,ncomptot)
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      g_co2      =  nqchem_min
+      g_co       =  nqchem_min + 1
+      g_o        =  nqchem_min + 2
+      g_o1d      =  nqchem_min + 3
+      g_o2       =  nqchem_min + 4
+      g_o3       =  nqchem_min + 5
+      g_h        =  nqchem_min + 6
+      g_h2       =  nqchem_min + 7
+      g_oh       =  nqchem_min + 8
+      g_ho2      =  nqchem_min + 9
+      g_h2o2     =  nqchem_min + 10
+      g_n2       =  nqchem_min + 11
+      g_ar       =  nqchem_min + 12
+      g_h2o      =  nqmx
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the molecular diffusion
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c  Atomic oxygen must always be the LAST species of the list as 
+c it is the dominant species at high altitudes.  
+      i_co   = 1
+      i_n2   = 2
+      i_o2   = 3
+      i_co2  = 4
+      i_h2   = 5
+      i_h    = 6
+      i_oh   = 7
+      i_ho2  = 8
+      i_h2o  = 9
+      i_h2o2 = 10
+      i_o1d  = 11
+      i_o3   = 12
+      i_ar   = 13
+      i_o    = 14
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     array to relate local indexes to gcm indexes
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      gcmind(i_co)  =   g_co
+      gcmind(i_n2)  =   g_n2
+      gcmind(i_o2)  =   g_o2
+      gcmind(i_co2) =   g_co2
+      gcmind(i_h2)  =   g_h2
+      gcmind(i_h)   =   g_h
+      gcmind(i_oh)  =   g_oh
+      gcmind(i_ho2) =   g_ho2
+      gcmind(i_h2o) =   g_h2o
+      gcmind(i_h2o2)=   g_h2o2
+      gcmind(i_o1d) =   g_o1d
+      gcmind(i_o3)  =   g_o3
+      gcmind(i_o)   =   g_o
+      gcmind(i_ar)   =  g_ar
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+
+      dij(i_h2,i_co)   = 0.0000651
+      dij(i_h2,i_n2)   = 0.0000674
+      dij(i_h2,i_o2)   = 0.0000697
+      dij(i_h2,i_co2)  = 0.0000550
+      dij(i_h2,i_h2)   = 0.0
+      dij(i_h2,i_h)    = 0.0
+      dij(i_h2,i_oh)   = 0.0	!0003
+      dij(i_h2,i_ho2)  = 0.0	!0003
+      dij(i_h2,i_h2o)  = 0.0	!0003
+      dij(i_h2,i_h2o2) = 0.0	!0003
+      dij(i_h2,i_o1d)  = 0.0
+      dij(i_h2,i_o3)   = 0.0	!0003
+      dij(i_h2,i_o)    = 0.0
+      dij(i_h2,i_ar)   = 0.0
+
+c      dij(i_h,i_o)     = 0.0000144
+      dij(i_h,i_o)     = 0.000114
+
+       print*,' COEFF CALC'
+       open(56,file='coeffs.dat',status='unknown')
+      do n=1,ncomptot
+        if (dij(i_h2,n).gt.0.0) then
+          do nn=n,ncomptot
+            dij(nn,n)=dij(i_h2,n)
+     &                  *sqrt(mmol(g_h2)/mmol(gcmind(nn)))
+            if(n.eq.nn) dij(nn,n)=1.0
+            dij(n,nn)=dij(nn,n)
+          enddo 
+        endif
+        if (dij(i_h2,n).eq.0.0) then
+          dnh=dij(i_h,i_o)*sqrt(mmol(g_o)/mmol(gcmind(n)))
+          do nn=n,ncomptot
+            dij(nn,n)=dnh*sqrt(mmol(g_h)/mmol(gcmind(nn)))
+            if(n.eq.nn) dij(nn,n)=1.0
+            dij(n,nn)=dij(nn,n)
+          enddo 
+        endif
+      enddo 
+
+      do n=1,ncomptot
+        do nn=n,ncomptot
+          write(56,*) n,nn,dij(n,nn)	!*1.e5/1.381e-23/(273**1.75)
+        enddo
+      enddo
+      close(56)
+
+
+      return   
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/molvis.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/molvis.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/molvis.F	(revision 57)
@@ -0,0 +1,193 @@
+       SUBROUTINE molvis(ptimestep,pplay,pplev,pt,pdteuv,pdtconduc,pvel,
+     $                   tsurf,zzlev,zzlay,zdvelmolvis)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Molecular Viscosity Diffusion
+c  
+c   Based on conduction.F  by N. Descamp, F. Forget 05/1999
+c
+c   modified by M. Angelats i Coll
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c-----------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "surfdat.h"
+#include "chimiedata.h"
+#include "conc.h"
+
+c   arguments:
+c   ----------
+
+      REAL ptimestep
+      REAL pplay(ngridmx,nlayermx)
+      REAL pplev(ngridmx,nlayermx+1)
+      REAL zzlay(ngridmx,nlayermx)
+      REAL zzlev(ngridmx,nlayermx+1)
+      real pt(ngridmx,nlayermx)
+      real tsurf(ngridmx)
+      REAL pvel(ngridmx,nlayermx)
+      REAL pdvel(ngridmx,nlayermx)
+      real pdteuv(ngridmx,nlayermx)
+      real pdtconduc(ngridmx,nlayermx)
+
+      real zdvelmolvis(ngridmx,nlayermx)
+
+c   local:
+c   ------
+
+      INTEGER l,ig, ngrid,nz
+      real Akk,skk,phitop,velsurf,fac, m, tmean
+      REAL zvel(nlayermx)
+      real zt(nlayermx)
+      REAL alpha(nlayermx)
+      REAL lambda(nlayermx)
+      real muvol(nlayermx)
+      REAL C(nlayermx)
+      real D(nlayermx)
+      real den(nlayermx)
+      REAL pdvelm(nlayermx)
+      REAL zlay(nlayermx)
+      real zlev(nlayermx+1)
+
+c   constants used locally
+c    ---------------------
+c     The atmospheric conductivity is a function of temperature T :
+c      conductivity = Akk* T**skk
+c     Molecular viscosity is related to thermal conductivity by:
+c       conduc = 0.25*(9*gamma - 5)* Cv * molvis
+c     where gamma = Cp/Cv.  For dry air.
+
+
+      PARAMETER (skk=0.69)
+
+      PARAMETER (velsurf =0.0)
+      
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+c-----------------------------------------------------------------------
+c   calcul des coefficients alpha et lambda
+c-----------------------------------------------------------------------
+
+      IF (firstcall) THEN
+        write(*,*)'molvis: coeff of molecular viscosity Akk,skk,factor'
+        write(*,*) Akk,skk,fac
+        firstcall = .false.
+      END IF
+
+! Initialize phitop
+      phitop=0.0
+
+      ngrid=ngridmx
+      nz=nlayermx
+
+      do ig=1,ngrid
+
+        zt(1)=pt(ig,1)+(pdteuv(ig,1)+pdtconduc(ig,1))*ptimestep
+        zvel(1)=pvel(ig,1)
+c        zlay(1)=-log(pplay(ig,1)/pplev(ig,1))*Rnew(ig,1)*zt(1)/g
+c        zlev(1)=0.0
+
+        zlay(1)=zzlay(ig,1)
+        zlev(1)=zzlev(ig,1)
+
+        do l=2,nz
+          zt(l)=pt(ig,l)+(pdteuv(ig,l)+pdtconduc(ig,l))*ptimestep
+          zvel(l)=pvel(ig,l)
+c          tmean=zt(l)
+c          if(zt(l).ne.zt(l-1)) tmean=(zt(l)-zt(l-1))/log(zt(l)/zt(l-1))
+c          zlay(l)= zlay(l-1)
+c     &          -log(pplay(ig,l)/pplay(ig,l-1))*Rnew(ig,l-1)*tmean/g
+c          zlev(l)= zlev(l-1)
+c     &         -log(pplev(ig,l)/pplev(ig,l-1))*Rnew(ig,l-1)*tmean/g
+        zlay(l)=zzlay(ig,l)
+        zlev(l)=zzlev(ig,l)
+        enddo
+
+c          zlev(nz+1)= zlev(nz)
+c     &         -log(max(pplev(ig,nz+1),1.e-30)/pplev(ig,nz))
+c     &          *Rnew(ig,nz)*tmean/g
+c          if(pplev(ig,nz+1).eq.0.)
+c     &       zlev(nz+1)=zlev(nz)+(zlay(nz)-zlay(nz-1))
+
+          zlev(nz+1)= zlev(nz)+10000.
+
+        fac=0.25*(9.*cpnew(ig,1)-5.*(cpnew(ig,1)-rnew(ig,1))) 
+        Akk=Akknew(ig,1)
+        lambda(1)=Akk*tsurf(ig)**skk/zlay(1)/fac   
+c        write(*,*) 'rnew(ig,nz)  ',ig , rnew(ig,nz)
+
+        DO l=2,nz
+          fac=(9.*cpnew(ig,l)-5.*(cpnew(ig,l)-rnew(ig,l)))/4. 
+          Akk=Akknew(ig,l)
+          lambda(l)=Akk/fac*zt(l)**skk/(zlay(l)-zlay(l-1)) 
+        ENDDO
+    
+        DO l=1,nz-1
+          muvol(l)=pplay(ig,l)/(rnew(ig,l)*zt(l)) 
+          alpha(l)=(muvol(l)/ptimestep)*(zlev(l+1)-zlev(l))
+        ENDDO
+        muvol(nz)=pplay(ig,nz)/(rnew(ig,nz)*zt(nz)) 
+        alpha(nz)=(muvol(nz)/ptimestep)*(zlev(nz+1)-zlev(nz))
+
+c--------------------------------------------------------------------
+c
+c     calcul des coefficients C et D
+c
+c-------------------------------------------------------------------
+
+      den(1)=alpha(1)+lambda(2)+lambda(1)
+      C(1)=lambda(1)*(velsurf-zvel(1))+lambda(2)*(zvel(2)-zvel(1))
+      C(1)=C(1)/den(1)	     
+      D(1)=lambda(2)/den(1)           
+   
+      DO l = 2,nz-1
+         den(l)=alpha(l)+lambda(l+1)
+         den(l)=den(l)+lambda(l)*(1-D(l-1))
+         
+         C(l) =lambda(l+1)*(zvel(l+1)-zvel(l)) 
+     $        +lambda(l)*(zvel(l-1)-zvel(l)+C(l-1))    
+         C(l) =C(l)/den(l)           
+
+         D(l) =lambda(l+1) / den(l)
+      ENDDO 
+
+      den(nz)=alpha(nz) + lambda(nz) * (1-D(nz-1))
+      C(nz)=C(nz-1)+zvel(nz-1)-zvel(nz) 
+      C(nz)=(C(nz)*lambda(nz)+phitop) / den(nz) 
+       	 	
+c----------------------------------------------------------------------
+c
+c      calcul de la nouvelle pdvelm 
+c
+c----------------------------------------------------------------------
+
+      DO l=1,nz
+         pdvelm(l)=0.
+      ENDDO
+         pdvelm(nz)=C(nz)
+      DO l=nz-1,1,-1
+         pdvelm(l)=C(l)+D(l)*pdvelm(l+1)
+      ENDDO 
+c-----------------------------------------------------------------------
+c
+c     calcul de la tendance zdvelmolvis
+c
+c-----------------------------------------------------------------------
+    
+      DO l=1,nz
+        zdvelmolvis(ig,l)=pdvelm(l)/ptimestep
+      ENDDO
+
+      ENDDO             ! boucle sur ngrid
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param.h	(revision 57)
@@ -0,0 +1,62 @@
+c***********************************************
+
+c	param.par
+
+c	Parameters for paramhr.f
+c***********************************************
+
+	integer    ninter
+	parameter  (ninter=33)
+
+	integer    nabs
+	parameter  (nabs=6)
+
+	integer    nz2
+	parameter  (nz2=203)
+
+	integer    ninter2
+        parameter  (ninter2=16)
+
+	real       kboltzman                  !cte Boltzman
+	parameter  (kboltzman = 1.381e-16)
+	
+	real       n_avog                    !# de Avogadro
+	parameter  (n_avog = 6.023e23)
+
+	real       gg                        !cte gravitacion
+	parameter  (gg = 6.67259e-8)
+
+	real       masa                      !masa de Marte(g)
+	parameter  (masa = 6.4163e26)
+
+	real       radio
+	parameter  (radio = 3390.)           !radio de Marte(km)
+
+	real       pmco2
+	parameter  (pmco2 = 44.)
+
+	real       pmo3p
+	parameter  (pmo3p = 16.)
+
+	real       pmo2
+	parameter  (pmo2 = 32.)
+
+	real       pmh2o2
+	parameter  (pmh2o2 = 36.)
+
+	real       cpco2
+	parameter  (cpco2=20.0e6)
+
+	real       cpo2
+	parameter  (cpo2=0.9194e7)
+
+	real       cpo3p
+	parameter  (cpo3p=1.30e7)
+
+	integer	   nreact
+	parameter  (nreact=22)
+
+	integer    nzmax
+	parameter  (nzmax=210)
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_read.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_read.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_read.F	(revision 57)
@@ -0,0 +1,232 @@
+      subroutine param_read
+
+      implicit none
+
+
+c     common variables and constants
+
+#include "param.h"
+#include "param_v3.h"
+#include "datafile.h"
+
+
+c     local variables
+
+      integer    i,j,k,inter                          !indexes
+      integer ierr,lnblnk 
+      real       nada
+      external lnblnk
+
+     
+c*************************+PROGRAM STARTS**************************
+
+
+c     data
+
+      data anchint/4.9,5.3,6.1,12.8,2.0,6.9,11.8,0.4,1.9,4.9,0.9,4.0,
+     $6.9,4.9,4.9,10.2,5.6,1.9,0.9,0.9,0.9,0.9,3.7
+     $,13.1,3.9,6.0,4.8,23.9,8.4,8.5,26.8,7.5,127.6/
+
+      data (crscabsi2(1,j),j=1,ninter2) /0.0,4.42e-18,7.51e-18
+     $,1.498e-17,2.344e-17,2.388e-17,2.927E-17,3.161e-17,3.161e-17,
+     $3.4e-17,3.4e-17,2.588e-17,2.596e-17,2.248e-17,3.183e-17,
+     $1.284e-17/
+
+      data (crscabsi2(2,j),j=1,ninter2) /2.736e-19,1.055e-18,4.789e-18
+     $,1.063e-17,1.559e-17,1.698e-17,2.164e-17,2.241e-17,2.427e-17,
+     $2.444e-17,2.502e-17,2.516e-17,2.907e-17,3.649e-17,3.066e-17,
+     $2.093e-17/
+
+      data (crscabsi2(3,j),j=1,ninter2) /2.603e-19,6.985e-19,3.97e-18
+     $,6.621e-18,8.433e-18,9.011e-18,9.862e-18,1.033e-17,1.012e-17,
+     $1.033e-17,1.033e-17,1.034e-17,9.0e-18,3.564e-18,3.572e-18
+     $,3.47E-18/
+
+      data freccen /3.4,7.5,14.5,23.0,30.3,34.1,49.6,50.5,52.5,56.0,
+     $59.0,61.5,68.7,73.1,78.4,83.1,92.4,97.5,99.3,100.1,100.7,102.1,
+     $104.5,116.8,121.3,127.0,130.6,153.7,162.8,171.4
+     $,195.6,206.3,273.5/
+
+      data co2crsc195/3.691e-19,4.44216e-20,3.86945e-19,5.94208e-19,
+     $2.93217e-19,7.58769e-20,8.60192e-21,4.20007e-24,2.29996e-26/
+
+      data co2crsc295/3.691e-19,5.21572e-20,4.23488e-19,6.54728e-19,
+     $3.30227e-19,1.03183e-19,1.55722e-20,1.72317e-23,7.0e-25/
+
+
+c     Reads tabulated functions
+
+      open(210, status = 'old',
+     $file=datafile(1:lnblnk(datafile))//'/EUVDAT/coln.dat',iostat=ierr)
+
+      IF (ierr.NE.0) THEN
+       write(*,*)'cant find directory EUVDAT and content coln.dat'
+       write(*,*)'(in aeronomars/param_read.F)'
+       write(*,*)'It should be in :',datafile(1:lnblnk(datafile)),'/'
+       write(*,*)'1) You can change this directory address in '
+       write(*,*)'   file phymars/datafile.h'
+       write(*,*)'2) If necessary, EUVDAT (and other datafiles)'
+       write(*,*)'   can be obtained online on:'
+       write(*,*)'   http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+       STOP
+      ENDIF
+
+      open(220,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j2_an.dat')
+      open(230,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j3_an.dat')
+      open(240,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j1_an.dat')
+      open(250,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j2_bn.dat')
+      open(260,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j2_cn.dat')
+      open(270,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j1_bn.dat')
+      open(280,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j1_cn.dat')
+      open(290,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j1_dn.dat')
+      open(150,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j4n.dat')
+      open(160,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j5n.dat')
+      open(170,file=datafile(1:lnblnk(datafile))//'/EUVDAT/j6n.dat')
+
+      do i=210,290,10
+         read(i,*)
+         read(i,*)
+      end do
+
+      do i=150,170,10
+         read(i,*)
+         read(i,*)
+      end do
+
+      do i=nz2,1,-1
+        read(210,*) c23(i),(c123(j,i),j=2,ninter2),c12(i),c1(i),ch2o2(i)
+      end do
+
+      do i=nz2,1,-1
+         read(220,*) (jabsifotsint(j,2,i),j=1,ninter2)
+      end do
+      
+      do i=nz2,1,-1
+         read(230,*) (jabsifotsint(j,3,i),j=1,ninter2)
+      end do
+
+      do i=nz2,1,-1
+         read(240,*) (jabsifotsint(j,1,i),j=2,ninter2)
+      end do
+
+      do i=nz2,1,-1
+         read(250,*) (jabsifotsint(j,2,i),j=17,24)
+      end do
+
+      do i=nz2,1,-1
+         read(260,*) (jabsifotsint(j,2,i),j=25,31)
+      end do
+
+      do i=nz2,1,-1
+         read(270,*) (jabsifotsint(j,1,i),j=17,24)
+      end do
+
+      do i=nz2,1,-1
+         read(280,*) (jabsifotsint(j,1,i),j=25,31)
+      end do
+
+      do i=nz2,1,-1
+         read(290,*) jabsifotsint(32,1,i)
+      end do
+
+      do i=nz2,1,-1
+         read(160,*) (jabsifotsint(j,5,i),j=1,15)
+      end do
+
+      do i=nz2,1,-1
+         read(150,*) (jabsifotsint(j,4,i),j=25,31)
+      end do
+
+      do i=nz2,1,-1
+         read(170,*) (jabsifotsint(j,6,i),j=25,33)
+      end do
+
+      do i=210,290,10
+         close(i)
+      end do
+
+      do i=150,170,10
+         close(i)
+      end do
+
+
+c     reads t0
+
+      open(120,file=datafile(1:lnblnk(datafile))//'/EUVDAT/t0.dat')
+      do i=1,201
+         read(120,*)t0(i)
+      end do
+      close(120)
+
+      open(100,file=datafile(1:lnblnk(datafile))//'/EUVDAT/flujo.dat')
+      do i=1,ninter
+         read(100,*) inter,fluxtophr(i)
+      end do
+      close(100)
+
+
+      open(99,file=datafile(1:lnblnk(datafile))//'/EUVDAT/varflujo.dat')
+      read(99,*)
+      do i=1,24
+         read(99,*) inter,ct1(i),p1(i),ct2(i),p2(i),nada
+      end do
+      close(99)
+
+c     eficiencias de disociacion (de Torr et al, 1979)
+
+      do inter=1,11
+         efdisco2(inter) = 0.
+         efdiso2(inter) = 0.
+      end do
+
+      do inter=1,15
+         efdish2(inter) = 1.
+      end do
+
+      efdisco2(12) = 0.183
+      efdiso2(12) = 0.003
+
+      efdisco2(13) = 0.163
+      efdiso2(13) = 0.170
+
+      efdisco2(14) = 0.243
+      efdiso2(14) =0.180
+
+      efdisco2(15) = 0.323
+      efdiso2(15) =0.653
+
+      efdisco2(16) = 0.235
+      efdiso2(16) =0.616
+
+      do inter=17,32
+         efdisco2(inter) = 1.0
+      end do
+
+      efdiso2(17) = 0.399
+      do inter=18,20
+         efdiso2(inter) = 0.261
+      end do
+
+      do inter=21,23
+         efdiso2(inter) = 0.755
+      end do
+
+
+      do inter=24,31
+         efdiso2(inter) = 1.
+      end do
+
+      do inter=25,31
+         efdish2o(inter) = 1.
+      end do
+
+      do inter=25,33
+         efdish2o2(inter) = 1.
+      end do
+
+
+      return
+
+
+      end
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_v3.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_v3.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/param_v3.h	(revision 57)
@@ -0,0 +1,95 @@
+c**********************************************************************
+
+c	param.cmn
+	
+c	fgg     mar 02          first version
+c**********************************************************************
+
+      common/uv/ anchint,crscabsi2,freccen,c123,c1,c2,c12,c23,ch2o2
+     $ ,jabsifotsint,jfotsout,co2crsc195,co2crsc295,fluxtop,t0
+     
+     
+
+
+      real       anchint(ninter)          !widht of each interval
+      real       crscabsi2(nabs,ninter)    !cross section
+      real       freccen(ninter)          !representative wavelenght
+      real       c123(ninter2,nz2)        !column densities (cm^-2)
+                                          !(CO2+O2+O3P)
+      real       c1(nz2)                  !idem (CO2) (cm^-2)
+      real       c2(nz2)                  !idem (O2) (cm^-2)
+      real       c12(nz2)                 !idem (CO2+O2) (cm^-2)
+      real       c23(nz2)                 !idem (O2+O3P) (cm^-2)
+      real       ch2o2(nz2)               !idem (H2O2) (cm^-2)
+      real       jabsifotsint(ninter,nabs,nzmax) !photoabsorption
+                                                 !coefficients (fot/s)
+      real       jfotsout(ninter,nabs,nzmax)
+      real       co2crsc195(9)
+      real       co2crsc295(9)
+      real       fluxtop(ninter)
+      real       t0(nzmax)
+      
+
+
+      common/fotoquimica/  ch2, ch3, ch4, ch5, ch7,ch9,ch10,ch11,
+     $                     ch13,ch14,ch15,ch18,ch19,ch20,ch21
+     $			   ,jdistot,jdistot_b
+
+      real*8 ch2, ch3, ch4, ch5, ch7,ch9,ch10,ch11,ch13,ch14,ch15,ch18
+      real*8 ch19,ch20,ch21
+						  !reaction rates
+      real jdistot(nabs,nzmax)    !photodissociation rates
+      real jdistot_b(2,nzmax)
+
+
+
+      common/prod/ Pco2,Po2,Po3p,Pco,Ph,Poh,Pho2,Ph2,Ph2o,Po1d,Ph2o2,
+     $		   Pco2tot,Po2tot,Po3ptot,Pcotot,Phtot,Pohtot,
+     $             Pho2tot,Ph2tot,Ph2otot,Po1dtot,Ph2o2tot
+	
+      real*8 Pco2(nzmax,nreact),Po2(nzmax,nreact),Po3p(nzmax,nreact)
+      real*8 Pco(nzmax,nreact),Ph(nzmax,nreact),Poh(nzmax,nreact)
+      real*8 Pho2(nzmax,nreact),Ph2(nzmax,nreact),Ph2o(nzmax,nreact)
+      real*8 Po1d(nzmax,nreact),Ph2o2(nzmax,nreact)
+      real*8 Pco2tot(nzmax),Po2tot(nzmax),Po3ptot(nzmax),Pcotot(nzmax)
+      real*8 Phtot(nzmax)
+      real*8 Pohtot(nzmax),Pho2tot(nzmax),Ph2tot(nzmax),Ph2otot(nzmax)
+      real*8 Po1dtot(nzmax),Ph2o2tot(nzmax)
+
+
+      common/loss/ Lco2,Lo2,Lo3p,Lco,Lh,Loh,Lho2,Lh2,Lh2o,Lo1d,Lh2o2,
+     $		   Lco2tot,Lo2tot,Lo3ptot,Lcotot,Lhtot,Lohtot,
+     $             Lho2tot,Lh2tot,Lh2otot,Lo1dtot,Lh2o2tot
+	
+      real*8 Lco2(nzmax,nreact),Lo2(nzmax,nreact),Lo3p(nzmax,nreact)
+      real*8 Lco(nzmax,nreact),Lh(nzmax,nreact),Loh(nzmax,nreact)
+      real*8 Lho2(nzmax,nreact),Lh2(nzmax,nreact),Lh2o(nzmax,nreact)
+      real*8 Lo1d(nzmax,nreact),Lh2o2(nzmax,nreact)
+      real*8 Lco2tot(nzmax),Lo2tot(nzmax),Lo3ptot(nzmax),Lcotot(nzmax)
+      real*8 Lhtot(nzmax),Lohtot(nzmax),Lho2tot(nzmax),Lh2tot(nzmax)
+      real*8 Lh2otot(nzmax),Lo1dtot(nzmax),Lh2o2tot(nzmax)
+
+
+      common/vida/ tminco2,tmino2,tmino3p,tminco,tminh,tminoh,tminho2
+     $               ,tminh2,tminh2o,tmino1d,tminh2o2
+
+    	real*8 tminco2(nzmax),tmino2(nzmax),tmino3p(nzmax),tminco(nzmax)
+    	real*8 tminh(nzmax),tminoh(nzmax),tminho2(nzmax),tminh2(nzmax)
+    	real*8 tminh2o(nzmax),tmino1d(nzmax),tminh2o2(nzmax)
+
+
+      common/flujoctes/ fluxtophr,ct1,p1,ct2,p2   
+ 
+      real fluxtophr(ninter)
+      real ct1(ninter),p1(ninter),ct2(ninter),p2(ninter)       
+
+      common/phdisef/ efdisco2, efdiso2, efdish2, efdish2o, efdish2o2
+
+      real efdisco2(ninter), efdiso2(ninter), efdish2o(ninter)
+      real efdish2o2(ninter), efdish2(ninter)
+
+
+
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/paramfoto.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/paramfoto.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/paramfoto.F	(revision 57)
@@ -0,0 +1,599 @@
+c**********************************************************************
+      
+      subroutine paramfoto
+     $(lswitch,zdens,tx,timestep,zenit,nz,co2x,o2x,o3px,cox,hx,ohx,
+     & ho2x,h2x,h2ox,h2o2x,o1dx)
+
+c     oct 2002      fgg
+c**********************************************************************
+
+      implicit none
+
+      include 'param.h'
+      include 'param_v3.h'
+
+c     arguments
+
+      integer nz,lswitch
+      real zdens(nz)
+      real tx(nz)
+      real co2x(nz),o2x(nz),o3px(nz),cox(nz),hx(nz),ohx(nz)
+      real    h2x(nz),h2ox(nz),h2o2x(nz),o1dx(nz),ho2x(nz)
+      real    zenit
+      real    timestep
+
+c     local variables
+
+      real*8    dt,deltat
+      integer nt, ntmax
+      real*8    tauco2(nzmax,nreact)
+      real*8    tauo2(nzmax,nreact)
+      real*8    tauo3p(nzmax,nreact)
+      real*8    tauco(nzmax,nreact)
+      real*8    tauh(nzmax,nreact)
+      real*8    tauoh(nzmax,nreact)
+      real*8    tauho2(nzmax,nreact)
+      real*8    tauh2(nzmax,nreact)
+      real*8    tauh2o(nzmax,nreact)
+      real*8    tauo1d(nzmax,nreact)
+      real*8    tauh2o2(nzmax,nreact)
+      real*8    co2x8,o2x8,o3px8,cox8,hx8,ohx8,ho2x8,h2x8,h2ox8
+      real*8    h2o2x8,o1dx8
+      real*8    o1dx8aux,ohx8aux,ho2x8aux,dif_o1d,dif_oh,dif_ho2
+      real*8    timestep8
+      real*8    jdistot8(nabs,nzmax)
+      real*8    jdistot8_b(2,nzmax)
+      real*8    tx8
+
+      real*8    tmin(nzmax)
+      integer i,j,k,nada,n
+
+      real*8    auxp,auxl
+      
+      character*1 o1d_eq(nzmax)
+      character*1 oh_eq(nzmax)
+      character*1 ho2_eq(nzmax)
+      character*1 dn
+
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+
+      if (firstcall) then
+        firstcall= .false.
+        print*,'FOTO'
+      endif
+
+c 123  format(1x,f10.7,11(tr3,e12.7))
+
+c**********************************************************************
+
+C     Start: altitude loop
+      timestep8=dble(timestep)
+
+      do i=nz,lswitch,-1
+         
+
+c     Concentrations to real*8
+
+         co2x8=dble(co2x(i))
+         o2x8=dble(o2x(i))
+         o3px8=dble(o3px(i))
+         cox8=dble(cox(i))
+         hx8=dble(hx(i))
+         ohx8=dble(ohx(i))
+         ho2x8=dble(ho2x(i))
+         h2x8=dble(h2x(i))
+         h2ox8=dble(h2ox(i))
+         h2o2x8=dble(h2o2x(i))
+         o1dx8=dble(o1dx(i))
+         tx8=dble(tx(i))
+
+
+c     reaction rates         
+
+         call getch(tx8)
+
+c         print*,i,co2x(i),o2x(i),o3px(i),cox(i),hx(i),ohx(i),ho2x(i),
+c     &            h2x(i),h2ox(i),h2o2x(i),o1dx(i),tx(i),zdens(i)
+
+
+c     photodissotiation rates
+
+         jdistot(1,i) = 0.
+         jdistot(2,i) = 0.
+         jdistot(3,i) = 0.
+         jdistot(4,i) = 0.
+         jdistot(5,i) = 0.
+         jdistot(6,i) = 0.
+         jdistot_b(1,i) = 0.
+         jdistot_b(2,i) = 0.
+
+         call phdisrate(zenit,i)
+
+         do j=1,6
+            jdistot8(j,i) = dble(jdistot(j,i))
+         end do
+         jdistot8_b(1,i) = dble(jdistot_b(1,i))
+         jdistot8_b(2,i) = dble(jdistot_b(2,i))
+         
+         
+c     Lifetimes calculation
+
+         do j=1,nreact
+            tauco2(i,j) = 1.d30
+            tauo2(i,j) = 1.d30
+            tauo3p(i,j) = 1.d30
+            tauco(i,j) = 1.d30
+            tauh(i,j) = 1.d30
+            tauoh(i,j) = 1.d30
+            tauho2(i,j) = 1.d30
+            tauh2(i,j) = 1.d30
+            tauh2o(i,j) = 1.d30
+            tauo1d(i,j) = 1.d30
+            tauh2o2(i,j) = 1.d30
+         end do
+
+         if(jdistot8(1,i).gt.1d-30) tauco2(i,1) = 1.d0 / jdistot8(1,i)
+
+         if(ch2*o2x8*co2x8.gt.1d-30) 
+     $      tauh(i,2) = 1.d0 / (ch2 * o2x8 * co2x8)  
+         if(ch2*hx8*co2x8.gt.1d-30)
+     $      tauo2(i,2) = 1.d0 / (ch2 * hx8 * co2x8)
+ 
+         if(ch3*o3px8.gt.1d-30) tauho2(i,3) = 1.d0 / (ch3 * o3px8)
+         if(ch3*ho2x8.gt.1d-30) tauo3p(i,3) = 1.d0 / (ch3 * ho2x8)
+ 
+         if(ch4*cox8.gt.1d-30) tauoh(i,4) = 1.d0 / (ch4 * cox8)
+         if(ch4*ohx8.gt.1d-30) tauco(i,4) = 1.d0 / (ch4 * ohx8)
+ 
+         if(ch5*ho2x8.gt.1d-30)tauho2(i,5) = 1.d0 / (2.d0 * ch5 * ho2x8)
+
+         if(jdistot8(6,i).gt.1d-30) tauh2o2(i,6) = 1.d0 / jdistot8(6,i)
+
+         if(ch7*ohx8.gt.1d-30) tauho2(i,7) = 1.d0 / (ch7 * ohx8)
+         if(ch7*ho2x8.gt.1d-30) tauoh(i,7) = 1.d0 / (ch7 * ho2x8)
+ 
+         if(jdistot8(4,i).gt.1d-30) tauh2o(i,8) = 1.d0 / jdistot8(4,i)
+
+         if(ch9*o1dx8.gt.1d-30) tauh2o(i,9) = 1.d0 / (ch9 * o1dx8)
+         if(ch9*h2ox8.gt.1d-30) tauo1d(i,9) = 1.d0 / (ch9 * h2ox8)
+
+         if(ch10*o3px8*co2x8.gt.1d-30) 
+     $     tauo3p(i,10) = 1.d0 / (2.d0 * ch10 * o3px8 * co2x8)
+
+         if(ch11*o3px8.gt.1d-30) tauoh(i,11) = 1.d0 / (ch11 * o3px8)
+         if(ch11*ohx8.gt.1d-30) tauo3p(i,11) = 1.d0 / (ch11 * ohx8)
+
+         if(jdistot8(2,i).gt.1d-30) tauo2(i,12) = 1.d0 / jdistot8(2,i)
+
+         if(ch13*hx8.gt.1d-30) tauho2(i,13) = 1.d0 / (ch13 * hx8)
+         if(ch13*ho2x8.gt.1d-30) tauh(i,13) = 1.d0 / (ch13 * ho2x8)
+
+         if(ch14*o1dx8.gt.1d-30) tauh2(i,14) = 1.d0 / (ch14 * o1dx8)
+         if(ch14*h2x8.gt.1d-30) tauo1d(i,14) = 1.d0 / (ch14 * h2x8)
+
+         if(ch15*ohx8.gt.1d-30) tauh2(i,15) = 1.d0 / (ch15 * ohx8)
+         if(ch15*h2x8.gt.1d-30) tauoh(i,15) = 1.d0 / (ch15 * h2x8)
+
+         if(jdistot8_b(1,i).gt.1d-30) tauco2(i,16) =1.d0/jdistot8_b(1,i)
+
+         if(jdistot8_b(2,i).gt.1d-30) tauo2(i,17) =1.d0/jdistot8_b(2,i)
+
+         if(ch18*ohx8.gt.1d-30) tauh2o2(i,18) = 1.d0 / (ch18 * ohx8)
+         if(ch18*h2o2x8.gt.1d-30) tauoh(i,18) = 1.d0 / (ch18 * h2o2x8)
+
+         if(ch19*co2x8.gt.1d-30) tauo1d(i,19) = 1.d0 / (ch19 * co2x8)
+
+         if(ch20*o2x8.gt.1d-30) tauo1d(i,20) = 1.d0 / (ch20 * o2x8)
+
+         if(ch21*o2x8*co2x8.gt.1d-30) tauo3p(i,21) = 1.d0 / 
+     $        (ch21 * o2x8 * co2x8)
+         if(ch21*o3px8*co2x8.gt.1d-30) tauo2(i,21) = 1.d0 / 
+     $        (ch21 * o3px8 * co2x8)
+
+         if(jdistot8(5,i).gt.1d-30) tauh2(i,22) = 1.d0 / jdistot8(5,i)
+
+         !minimum lifetime
+         tminco2(i) = 1.d30
+         tmino2(i) = 1.d30
+         tmino3p(i) = 1.d30
+         tminco(i) = 1.d30
+         tminh(i) = 1.d30
+         tminoh(i) = 1.d30
+         tminho2(i) = 1.d30
+         tminh2(i) = 1.d30
+         tminh2o(i) = 1.d30
+         tmino1d(i) = 1.d30
+         tminh2o2(i) = 1.d30
+         
+         do j=1,nreact
+            tminco2(i) = min(tminco2(i),tauco2(i,j))
+            tmino2(i) = min(tmino2(i),tauo2(i,j))
+            tmino3p(i) = min(tmino3p(i),tauo3p(i,j))
+            tminco(i) = min(tminco(i),tauco(i,j))
+            tminh(i) = min(tminh(i),tauh(i,j))
+            tminoh(i) = min(tminoh(i),tauoh(i,j))
+            tminho2(i) = min(tminho2(i),tauho2(i,j))
+            tminh2(i) = min(tminh2(i),tauh2(i,j))
+            tminh2o(i) = min(tminh2o(i),tauh2o(i,j))
+            tmino1d(i) = min(tmino1d(i),tauo1d(i,j))
+            tminh2o2(i) = min(tminh2o2(i),tauh2o2(i,j))
+         end do
+
+         tmin(i) = 1.d30
+         tmin(i) = min(tmin(i),tminco2(i))
+         tmin(i) = min(tmin(i),tmino2(i))
+         tmin(i) = min(tmin(i),tmino3p(i))
+         tmin(i) = min(tmin(i),tminco(i))
+         tmin(i) = min(tmin(i),tminh(i))
+         tmin(i) = min(tmin(i),tminh2(i))
+         tmin(i) = min(tmin(i),tminh2o(i))
+         tmin(i) = min(tmin(i),tminh2o2(i))
+
+
+         !Internal timestep
+         if(tmin(i)/10.d0.gt.timestep8*3600.d0) then
+            deltat = timestep8 * 3600.d0
+         else
+            deltat = tmin(i)/10.d0
+         end if
+         if(deltat.ne.timestep8*3600.d0) then
+            n=int(timestep8*3600.d0/deltat)+1
+            deltat=timestep8*3600.d0/n
+         endif
+
+
+         !Photochemical equilibrium for O1D,OH and HO2?
+         if(tmino1d(i).lt.deltat/5.d0) then
+            o1d_eq(i)='Y'
+         else 
+            o1d_eq(i)='N'
+c            o1d_eq(i)='Y'
+         endif
+         if(tminoh(i).lt.deltat/5.d0) then
+           oh_eq(i)='Y'
+         else
+           oh_eq(i)='N'
+c           oh_eq(i)='Y'
+         end if
+         if(tminho2(i).lt.deltat/5.d0) then
+            ho2_eq(i)='Y'
+         else
+            ho2_eq(i)='N'
+c            ho2_eq(i)='Y'
+         endif
+
+
+C     Start: temporal loop
+c        do dt=deltat,timestep8*3600.d0,deltat
+         do nt=1,int(timestep8*3600.d0/deltat)
+            dt=nt*deltat
+
+            !Productions and losses
+            do j=1,nreact
+               Lco2(i,j) = 0.d0
+               Pco2(i,j) = 0.d0
+               Lo2(i,j) = 0.d0
+               Po2(i,j) = 0.d0
+               Lo3p(i,j) = 0.d0
+               Po3p(i,j) = 0.d0
+               Lco(i,j) = 0.d0
+               Pco(i,j) = 0.d0
+               Ph(i,j) = 0.d0
+               Lh(i,j) = 0.d0
+               Poh(i,j) = 0.d0
+               Loh(i,j) = 0.d0
+               Pho2(i,j) = 0.d0
+               Lho2(i,j) = 0.d0
+               Ph2(i,j) = 0.d0
+               Lh2(i,j) = 0.d0
+               Ph2o(i,j) = 0.d0
+               Lh2o(i,j) = 0.d0
+               Po1d(i,j) = 0.d0
+               Lo1d(i,j) = 0.d0
+               Ph2o2(i,j) = 0.d0
+               Lh2o2(i,j) = 0.d0
+            end do
+            Pco2tot(i) = 0.d0
+            Lco2tot(i) = 0.d0
+            Po2tot(i) = 0.d0
+            Lo2tot(i) = 0.d0
+            Po3ptot(i) = 0.d0
+            Lo3ptot(i) = 0.d0
+            Pcotot(i) = 0.d0
+            Lcotot(i) = 0.d0
+            Phtot(i) = 0.d0
+            Lhtot(i) = 0.d0
+            Pohtot(i) = 0.d0
+            Lohtot(i) = 0.d0
+            Pho2tot(i) = 0.d0
+            Lho2tot(i) = 0.d0
+            Ph2tot(i) = 0.d0
+            Lh2tot(i) = 0.d0
+            Ph2otot(i) = 0.d0
+            Lh2otot(i) = 0.d0
+            Po1dtot(i) = 0.d0
+            Lo1dtot(i) = 0.d0
+            Ph2o2tot(i) = 0.d0
+            Lh2o2tot(i) = 0.d0
+
+
+c           R1: CO2 + hv -> CO + O
+
+            Lco2(i,1) = jdistot8(1,i)
+            Pco(i,1) = co2x8 * jdistot8(1,i)
+            Po3p(i,1) = co2x8 * jdistot8(1,i)
+
+
+c           R16(1b): CO2 + hv -> CO + O1D
+
+            Lco2(i,16) = jdistot8_b(1,i)
+            Pco(i,16) = co2x8 * jdistot8_b(1,i)
+            Po1d(i,16) = co2x8 * jdistot8_b(1,i)
+
+
+c           R2: H + O2 + CO2 -> HO2 + CO2
+
+            Lh(i,2) = ch2 * o2x8 * co2x8
+            Lo2(i,2) = ch2 * hx8 * co2x8
+            Pho2(i,2) = ch2 * hx8 * o2x8 * co2x8
+
+
+c           R3: O + HO2 -> OH + O2
+
+            Lo3p(i,3) = ch3 * ho2x8 
+            Lho2(i,3) = ch3 * o3px8
+            Poh(i,3) = ch3 * o3px8 * ho2x8
+            Po2(i,3) = ch3 * o3px8 * ho2x8
+
+
+c           R4: CO + OH -> CO2 + H
+
+            Lco(i,4) = ch4 * ohx8
+            Loh(i,4) = ch4 * cox8
+            Pco2(i,4) = ch4 * cox8 * ohx8
+            Ph(i,4) = ch4 * cox8 * ohx8
+
+
+c           R5: 2HO2 -> H2O2 + O2
+
+            Lho2(i,5) = 2.d0 * ch5 * ho2x8 
+            Po2(i,5) = ch5 * ho2x8 * ho2x8 
+            Ph2o2(i,5) = ch5 * ho2x8 * ho2x8
+
+
+c           R6: H2O2 + hv -> 2OH
+
+            Lh2o2(i,6) = jdistot8(6,i) 
+            Poh(i,6) = jdistot8(6,i) * h2o2x8
+
+
+c           R7: OH + HO2 -> H2O + O2
+
+            Loh(i,7) = ch7 * ho2x8 
+            Lho2(i,7) = ch7 * ohx8
+            Po2(i,7) = ch7 * ohx8 * ho2x8
+            Ph2o(i,7) = ch7 * ohx8 * ho2x8
+
+
+c           R8: H20 + hv -> H + OH
+
+            Lh2o(i,8) = jdistot8(4,i)
+            Ph(i,8) = jdistot8(4,i) * h2ox8
+            Poh(i,8) = jdistot8(4,i) * h2ox8
+
+
+c           R9: O(1D) + H2O -> 2OH
+
+            Lo1d(i,9) = ch9 * h2ox8
+            Lh2o(i,9) = ch9 * o1dx8
+            Poh(i,9) = 2.d0 * ch9 * o1dx8 * h2ox8 
+         
+
+c           R10: 2O + CO2 -> O2 + CO2
+
+            Lo3p(i,10) = 2.d0 * ch10 * o3px8 * co2x8  
+            Po2(i,10) = ch10 * o3px8 * o3px8 * co2x8
+
+
+c           R11: O + OH -> O2 + H
+
+            Lo3p(i,11) = ch11 * ohx8
+            Loh(i,11) = ch11 * o3px8
+            Po2(i,11) = ch11 * o3px8 * ohx8
+            Ph(i,11) = ch11 * o3px8 * ohx8
+
+
+c           R12: O2 + hv -> 2O
+
+            Lo2(i,12) = jdistot8(2,i)
+            Po3p(i,12) = 2.d0 * jdistot8(2,i) * o2x8
+
+
+c           R17(12b): O2 + hv -> O + O1D
+
+            Lo2(i,17) = jdistot8_b(2,i)
+            Po3p(i,17) = jdistot8_b(2,i) * o2x8
+            Po1d(i,17) = jdistot8_b(2,i) * o2x8
+
+
+c           R13: H + HO2 -> H2 + O2
+
+            Lh(i,13) = ch13 * ho2x8 
+            Lho2(i,13) = ch13 * hx8
+            Ph2(i,13) = ch13 * hx8 * ho2x8
+            Po2(i,13) = ch13 * hx8 * ho2x8
+
+
+c           R14: O(1D) + H2 -> H + OH
+
+            Lo1d(i,14) = ch14 * h2x8
+            Lh2(i,14) = ch14 * o1dx8
+            Ph(i,14) = ch14 * o1dx8 * h2x8
+            Poh(i,14) = ch14 * o1dx8 * h2x8
+
+
+c           R15: OH + H2 -> H + H20
+
+            Loh(i,15) = ch15 * h2x8
+            Lh2(i,15) = ch15 * ohx8
+            Ph(i,15) = ch15 * ohx8 * h2x8
+            Ph2o(i,15) = ch15 * ohx8 * h2x8
+
+
+c           R18: OH + H2O2 -> H2O + HO2
+
+            Loh(i,18) = ch18 * h2o2x8
+            Lh2o2(i,18) = ch18 * ohx8
+            Ph2o(i,18) = ch18 * ohx8 * h2o2x8
+            Pho2(i,18) = ch18 * ohx8 * h2o2x8
+
+
+c           R19: O(1D) + CO2 -> O + CO2
+
+            Lo1d(i,19) = ch19 * co2x8
+            Po3p(i,19) = ch19 * o1dx8 * co2x8
+
+
+c           R20: O(1D) + O2 -> O + O2
+
+            Lo1d(i,20) = ch20 * o2x8
+            Po3p(i,20) = ch20 * o1dx8 * o2x8
+
+
+c           R21: O + O2 + CO2 -> O3 + CO2
+
+            Lo3p(i,21) = ch21 * o2x8 * co2x8
+            Lo2(i,21) = ch21 * o3px8 * co2x8
+
+
+c           R22: H2 + hv -> 2H
+
+            Lh2(i,22) = jdistot8(5,i)
+            Ph(i,22) = 2.d0 * jdistot8(5,i) * h2x8 
+
+
+            do j=1,nreact
+               Pco2tot(i) = Pco2tot(i) + Pco2(i,j)
+               Lco2tot(i) = Lco2tot(i) + Lco2(i,j)
+               Po2tot(i) = Po2tot(i) + Po2(i,j)
+               Lo2tot(i) = Lo2tot(i) + Lo2(i,j)
+               Po3ptot(i) = Po3ptot(i) + Po3p(i,j)
+               Lo3ptot(i) = Lo3ptot(i) + Lo3p(i,j)
+               Pcotot(i) = Pcotot(i) + Pco(i,j)
+               Lcotot(i) = Lcotot(i) + Lco(i,j)
+               Phtot(i) = Phtot(i) + Ph(i,j)
+               Lhtot(i) = Lhtot(i) + Lh(i,j)
+               Pohtot(i) = Pohtot(i) + Poh(i,j)
+               Lohtot(i) = Lohtot(i) + Loh(i,j)
+               Pho2tot(i) = Pho2tot(i) + Pho2(i,j)
+               Lho2tot(i) = Lho2tot(i) + Lho2(i,j)
+               Ph2tot(i) = Ph2tot(i) + Ph2(i,j)
+               Lh2tot(i) = Lh2tot(i) + Lh2(i,j)
+               Ph2otot(i) = Ph2otot(i) + Ph2o(i,j)
+               Lh2otot(i) = Lh2otot(i) + Lh2o(i,j)
+               Po1dtot(i) = Po1dtot(i) + Po1d(i,j)
+               Lo1dtot(i) = Lo1dtot(i) + Lo1d(i,j)
+               Ph2o2tot(i) = Ph2o2tot(i) + Ph2o2(i,j)
+               Lh2o2tot(i) = Lh2o2tot(i) + Lh2o2(i,j)
+            end do
+
+
+            !New concentrations, implicit scheme
+            co2x8 = (co2x8 + Pco2tot(i) * deltat) /
+     $                (1.d0 + Lco2tot(i) * deltat)
+            o2x8 = (o2x8 + Po2tot(i) * deltat) /
+     $               (1.d0 + Lo2tot(i) * deltat)
+            o3px8 = (o3px8 + Po3ptot(i) * deltat) /
+     $                (1.d0 + Lo3ptot(i) * deltat)
+            cox8 = (cox8 + Pcotot(i) * deltat) /
+     $               (1.d0 + Lcotot(i) * deltat)
+            hx8 = (hx8 + Phtot(i) * deltat) /
+     $              (1.d0 + Lhtot(i) * deltat)
+             h2x8 = (h2x8 + Ph2tot(i) * deltat) /
+     $               (1.d0 + Lh2tot(i) * deltat)
+            h2ox8 = (h2ox8 + Ph2otot(i) * deltat) / 
+     $                (1.d0 + Lh2otot(i) * deltat)
+            h2o2x8 = (h2o2x8 + Ph2o2tot(i) * deltat) /
+     $                (1.d0 + Lh2o2tot(i) * deltat)
+
+            if(o1d_eq(i).eq.'Y') then
+               auxp=jdistot8_b(1,i)*co2x8+jdistot8_b(2,i)*o2x8
+               auxl=ch9*h2ox8+ch14*h2x8+ch19*co2x8+ch20*o2x8
+               if(auxl.ne.0.) then
+                  o1dx8=auxp/auxl
+               else
+                  o1dx8=o1dx8+Po1dtot(i)*deltat
+               endif
+            else
+               o1dx8 = (o1dx8 + Po1dtot(i) * deltat) /
+     $                   (1.d0 + Lo1dtot(i) * deltat)
+            end if
+
+            if(oh_eq(i).eq.'Y') then
+               auxp=ch3*o3px8*ho2x8+jdistot(4,i)*h2ox8+
+     $              2.d0*ch9*o1dx8*h2ox8+ch14*o1dx8*h2x8+
+     $              2.d0*jdistot(6,i)*h2o2x8
+               auxl=ch4*cox8+ch7*ho2x8+ch11*o3px8+ch15*h2x8+
+     $              ch18*h2o2x8
+               if(auxl.ne.0.) then
+                  ohx8=auxp/auxl
+               else
+                  ohx8=ohx8+Pohtot(i)*deltat
+               end if
+            else
+               ohx8 = (ohx8 + Pohtot(i) * deltat) /
+     $                  (1.d0 + Lohtot(i) * deltat)
+            end if
+
+            if(ho2_eq(i).eq.'Y') then
+               auxp=ch2*hx8*o2x8*co2x8+ch18*ohx8*h2o2x8
+               auxl=ch3*o3px8+2.d0*ch5*ho2x8+ch7*ohx8+ch13*hx8
+               if(auxl.ne.0.) then
+                  ho2x8=auxp/auxl
+               else
+                  ho2x8=ho2x8+Pho2tot(i)*deltat
+               end if
+            else
+               ho2x8 = (ho2x8 + Pho2tot(i) * deltat) /
+     $                  (1.d0 + Lho2tot(i) * deltat)
+            end if
+
+
+C        End: temporal loop
+         end do
+         
+         
+         co2x(i)  = real(co2x8)
+         o2x(i)   = real(o2x8)
+         o3px(i)  = real(o3px8)
+         cox(i)   = real(cox8)
+         hx(i)    = real(hx8)
+         ohx(i)   = real(ohx8)
+         ho2x(i)  = real(ho2x8)
+         h2x(i)   = real(h2x8)
+         h2ox(i)  = real(h2ox8)
+         h2o2x(i) = real(h2o2x8)
+         o1dx(i)  = real(o1dx8)
+
+c         co2x(i)=(co2x8)
+c         o2x(i)=(o2x8)
+c         o3px(i)=(o3px8)
+c         cox(i)=(cox8)
+c         hx(i)=(hx8)
+c         ohx(i)=(ohx8)
+c         ho2x(i)=(ho2x8)
+c         h2x(i)=(h2x8)
+c         h2ox(i)=(h2ox8)
+c         h2o2x(i)=(h2o2x8)
+c         o1dx(i)=(o1dx8)
+
+C     End: altitude loop
+      end do
+
+      return
+
+      end
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/perosat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/perosat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/perosat.F	(revision 57)
@@ -0,0 +1,140 @@
+      SUBROUTINE perosat(ig, ptimestep,
+     $                   pplev, pplay, zt,
+     &                   zy, pdqcloud, pdqscloud)
+      IMPLICIT NONE
+
+c=======================================================================
+c     Treatment of saturation of hydrogen peroxide (H2O2)
+c
+c     Modif de zq si saturation dans l'atmopshere
+c     si zq(ig,l)> zqsat(ig,l) ->    zq(ig,l)=zqsat(ig,l)
+c     Le test est effectue de bas en haut. H2O2 condense
+c    (si saturation) est remis dans la couche en dessous.
+c     H2O2 condense dans la couche du bas est depose a la surface
+c
+c     WARNING : H2O2 mixing ratio is assumed to be q(i_h2o2)    
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "chimiedata.h"
+#include "tracer.h"
+#include "conc.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ig
+      REAL ptimestep                ! pas de temps physique (s)
+      REAL pplev(ngridmx,nlayermx+1)! pression aux inter-couches (Pa)
+      REAL pplay(ngridmx,nlayermx)  ! pression au milieu des couches (Pa)
+      REAL zt(nlayermx)             ! temperature au centre des couches (K)
+                                    ! deja mise a jour dans calchim
+
+c   Traceurs :
+      real zy(nlayermx,nqmx)        ! traceur (fraction molaire sortie chimie)
+      real pdqcloud(ngridmx,nlayermx,nqmx) ! tendance condensation (kg/kg.s-1)
+      real pdqscloud(ngridmx,nqmx)         ! flux en surface (kg.m-2.s-1)
+      
+c   local:
+c   ------
+
+      INTEGER l,iq
+      INTEGER i_h2o2
+
+      REAL zysat(nlayermx)
+      REAL zynew(nlayermx)             ! mole fraction after condensation
+      REAL psat_hg                     ! pression saturante (mm Hg)
+      REAL psat_hpa                    ! pression saturante (hPa)
+
+c     Pour diagnostique :
+c     ~~~~~~~~~~~~~~~~~
+      REAL taucond(ngridmx,nlayermx)   ! taux de condensation (kg/kg/s-1)
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+c
+      do iq=1,nqmx
+       if (noms(iq).eq."h2o2") then
+          i_h2o2 = iq
+c         print *,'H2O2: ',noms(iq),' iq=',iq
+c      else
+c         print *,noms(iq),' iq=',iq
+       endif
+      enddo
+
+c    ----------------------------------------------
+c    
+c       Rapport de melange a saturation dans la couche l :
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c
+c       d'apres Lindner, Planet. Space Sci., 36, 125, 1988.
+c       domaine d'application: T < 220 K
+c
+        do l = 1,nlayermx
+
+c       print *,'ig=',ig,' l=',l,' i_h2o2=',i_h2o2
+c       print *,'y=',zy(l,i_h2o2),' T=',zt(l)
+
+             zynew(l) = zy(l,i_h2o2)
+
+             if (zt(l) .le. 220.) then
+               psat_hg = 10.**(11.98 - (3422./zt(l)))
+               psat_hpa = psat_hg*760./1013.
+               zysat(l) = (psat_hpa*100./pplay(ig,l))
+             else
+               zysat(l) = 1.e+30
+             end if
+
+c       print *,'ysat=',zysat(l)
+
+        end do
+
+c       taux de condensation (kg/kg/s-1) dans les differentes couches
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c       (Pour diagnostic seulement !)
+c
+        do l=1, nlayermx
+            taucond(ig,l)= max((zy(l,i_h2o2)-zysat(l))*mmol(i_h2o2)
+     $                         /(mmean(ig,l)*ptimestep),0.)
+        end do
+c
+c       Saturation couche nlay a 2 :  
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~
+c
+        do l=nlayermx,2, -1
+           if (zynew(l).gt.zysat(l)) then
+              zynew(l-1) =  zynew(l-1) + (zynew(l) - zysat(l))
+     &      *(pplev(ig,l)-pplev(ig,l+1))/(pplev(ig,l-1)-pplev(ig,l))
+
+              zynew(l)=zysat(l)
+           endif
+        enddo
+c
+c       Saturation couche l=1 
+c       ~~~~~~~~~~~~~~~~~~~~~
+c
+        if (zynew(1).gt.zysat(1)) then
+           pdqscloud(ig,i_h2o2)= (zynew(1)-zysat(1))*mmol(i_h2o2)
+     $   *(pplev(ig,1)-pplev(ig,2))/(mmean(ig,1)*g*ptimestep)
+c
+           zynew(1)=zysat(1)
+        end if
+c
+c       Tendance finale
+c       ~~~~~~~~~~~~~~~
+c
+        do l=1, nlayermx
+           pdqcloud(ig,l,i_h2o2)=(zynew(l) - zy(l,i_h2o2))*mmol(i_h2o2)
+     &                           /(mmean(ig,l)*ptimestep) 
+c          print *,'pdqcloud=',pdqcloud(ig,l,i_h2o2)
+        end do
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/phdisrate.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/phdisrate.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/phdisrate.F	(revision 57)
@@ -0,0 +1,109 @@
+c**********************************************************************
+
+      subroutine phdisrate(zenit,i)
+
+c     apr 2002       fgg           first version
+c**********************************************************************
+
+
+      implicit none
+
+      include 'param.h'
+      include 'param_v3.h'
+
+c     arguments
+
+      integer         i                !altitude
+      real            zenit
+
+c     local variables
+
+      integer         inter,iz
+      real            lambda
+      real            jdis(nabs,ninter,nzmax)
+      character*1     dn
+
+
+c**********************************************************************
+
+      if(zenit.gt.100.) then
+         dn='n'
+         else
+         dn='d'
+      end if
+
+      if(dn.eq.'n') then
+         jdistot(1,i) = 0.
+         jdistot(2,i) = 0.
+         jdistot(3,i) = 0.
+         jdistot(4,i) = 0.
+         jdistot(5,i) = 0.
+         jdistot(6,i) = 0.
+         jdistot_b(1,i) = 0.
+         jdistot_b(2,i) = 0.
+      else
+
+c     photodissociation rate
+
+         jdistot(1,i)=0.
+         jdistot(2,i)=0.
+         jdistot(4,i)=0.
+         jdistot(6,i)=0.
+         jdistot_b(1,i)=0.
+         jdistot_b(2,i)=0.
+         do inter=1,32
+            jdis(1,inter,i) = jfotsout(inter,1,i) * fluxtop(inter) 
+     $      * efdisco2(inter)
+            if(inter.gt.29.and.inter.le.32) then
+               jdistot(1,i) = jdistot(1,i) + jdis(1,inter,i)
+            else if(inter.le.29) then
+               jdistot_b(1,i) = jdistot_b(1,i) + jdis(1,inter,i)
+            end if
+         end do
+
+         do inter=1,31
+            jdis(2,inter,i) = jfotsout(inter,2,i) * fluxtop(inter)
+     $      * efdiso2(inter)
+            if(inter.ge.31) then
+               jdistot(2,i) = jdistot(2,i) + jdis(2,inter,i)
+            else if(inter.lt.31) then
+               jdistot_b(2,i) = jdistot_b(2,i) + jdis(2,inter,i)
+            end if
+         end do
+
+         jdistot(3,i) = 0.
+
+         do inter=25,31
+            jdis(4,inter,i) = jfotsout(inter,4,i) * fluxtop(inter)
+     $      * efdish2o(inter)
+            jdistot(4,i) = jdistot(4,i) + jdis(4,inter,i)
+         end do
+
+         do inter=1,15
+            jdis(5,inter,i) = jfotsout(inter,5,i) * fluxtop(inter)
+     $      * efdish2(inter)
+            jdistot(5,i) = jdistot(5,i) + jdis(5,inter,i)
+         end do
+
+         do inter=25,33
+            jdis(6,inter,i) = jfotsout(inter,6,i) * fluxtop(inter)
+     $      * efdish2o2(inter) 
+            jdistot(6,i) = jdistot(6,i) + jdis(6,inter,i)
+         end do 
+      end if
+
+
+      return
+      
+
+      end
+
+
+
+
+
+
+
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/photochemist_B.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/photochemist_B.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/photochemist_B.F	(revision 57)
@@ -0,0 +1,1562 @@
+c*****************************************************************
+c
+c     Photochemical routines for Scheme B
+c
+c     Author: Franck Lefevre
+c     ------
+c
+c     update 12/06/2003: compatibility with dust and iceparty
+c        (S. Lebonnois)
+c
+c*****************************************************************
+c
+      subroutine photochemist_B(lswitch,zycol, sza, ptimestep, press,
+c     $                          temp, dens, dist_sol)
+     $                          temp, dens, dist_sol, jo3)
+c
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "chimiedata.h" 
+#include "callkeys.h"
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     input/output:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      real zycol(nlayermx,nqmx)  ! chemical species volume mixing ratio
+c if iceparty, zycol(l,nqmx-1) is ice surface area (in microns^2/cm^3)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      real sza                   ! solar zenith angle (deg)
+      real ptimestep             ! physics timestep (s)
+      real press(nlayermx)       ! pressure (hpa)
+      real temp(nlayermx)        ! temperature (k)
+      real dens(nlayermx)        ! density (cm-3)
+      real dist_sol              ! sun distance (au) 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     output:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      real jo3(nlayermx)  ! photodissociation rate O3 -> O1D
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer phychemrat         ! ratio physics timestep/chemistry timestep
+      integer istep
+      integer i_o3,lev
+      integer nesp
+      integer lswitch
+c
+      parameter (nesp = 15)      ! number of species in the chemistry
+c
+      real ctimestep             ! chemistry timestep (s) 
+      real rm(nlayermx,nesp)     ! species volume mixing ratio 
+      real j(nlayermx,nd)        ! interpolated photolysis rates (s-1)
+      real icesurf(nlayermx)     ! ice surface area (cm^2/cm^3)
+      real rmo3(nlayermx)        ! ozone mixing ratio
+c
+c     reaction rates
+c
+      real a001(nlayermx), a002(nlayermx), a003(nlayermx)
+      real b001(nlayermx), b002(nlayermx), b003(nlayermx), 
+     $     b004(nlayermx), b005(nlayermx), b006(nlayermx)
+      real c001(nlayermx), c002(nlayermx), c003(nlayermx), 
+     $     c004(nlayermx), c005(nlayermx), c006(nlayermx), 
+     $     c007(nlayermx), c008(nlayermx), c009(nlayermx), 
+     $     c010(nlayermx), c011(nlayermx), c012(nlayermx),
+     $     c013(nlayermx), c014(nlayermx), c015(nlayermx), 
+     $     c016(nlayermx), c017(nlayermx), c018(nlayermx)
+      real d001(nlayermx), d002(nlayermx), d003(nlayermx)
+      real e001(nlayermx), e002(nlayermx)
+      real h001(nlayermx), h002(nlayermx)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     ctimestep : chemistry timestep (s)                         c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      ctimestep = 10.*60.
+c
+      phychemrat = int(ptimestep/ctimestep)
+c     print*,"PHYCHEMRAT = ",phychemrat
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     initialisation of chemical species and families            c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      call gcmtochim(zycol, lswitch, nesp, rm) 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     ice surface area for heterogenous chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      if (iceparty) then
+       do lev=1,lswitch-1
+        icesurf(lev)= zycol(lev,nqmx-1)*1.e-8 ! microns^2 -> cm^2
+       enddo
+      else
+       do lev=1,lswitch-1
+        icesurf(lev)=0.0e0
+       enddo
+      endif
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     compute reaction rates                                     c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      call chemrates(lswitch, dens, press, temp, icesurf,
+     $               a001, a002, a003,
+     $               b001, b002, b003, b004, b005, b006,
+     $               c001, c002, c003, c004, c005, c006,
+     $               c007, c008, c009, c010, c011, c012,
+     $               c013, c014, c015, c016, c017, c018,
+     $               d001, d002, d003,
+     $               e001, e002,
+     $               h001, h002)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     interpolation of photolysis rates in the lookup table      c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_o3 = 5 
+c
+      do lev=1,lswitch-1
+        rmo3(lev)=rm(lev,i_o3)
+      enddo
+
+      call phot(lswitch, press, temp, sza, dist_sol, rmo3, j)
+c
+      do lev=1,lswitch-1
+        jo3(lev) = j(lev,5)
+      enddo
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     loop over time within the physical timestep                c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do istep = 1,phychemrat
+         call chimie_B(lswitch,nesp, rm, j, dens, ctimestep, 
+     $                 press, temp, sza, dist_sol,
+     $                 a001, a002, a003,
+     $                 b001, b002, b003, b004, b005, b006,
+     $                 c001, c002, c003, c004, c005, c006,
+     $                 c007, c008, c009, c010, c011, c012,
+     $                 c013, c014, c015, c016, c017, c018,
+     $                 d001, d002, d003,
+     $                 e001, e002,
+     $                 h001, h002)
+c
+c        print*,'appel chimie ok iteration ', istep
+c
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     save chemical species for the gcm                          c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      call chimtogcm(zycol, lswitch, nesp, rm) 
+c
+      return
+      end
+c
+c*****************************************************************
+c
+      subroutine chimie_B(lswitch, nesp, rm, j, dens, dt, 
+     $                    press, t, sza, dist_sol,
+     $                    a001, a002, a003,
+     $                    b001, b002, b003, b004, b005, b006,
+     $                    c001, c002, c003, c004, c005, c006,
+     $                    c007, c008, c009, c010, c011, c012,
+     $                    c013, c014, c015, c016, c017, c018,
+     $                    d001, d002, d003,
+     $                    e001, e002,
+     $                    h001, h002)
+c
+c*****************************************************************
+c
+      implicit none 
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "chimiedata.h" 
+#include "callkeys.h" 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     input/output:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      integer lswitch         ! interface level between chemistries
+      integer nesp            ! number of species
+c
+      real rm(nlayermx,nesp)  ! volume mixing ratios 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      real dens(nlayermx)     ! density (cm-3)
+      real dt                 ! chemistry timestep (s) 
+      real j(nlayermx,nd)     ! interpolated photolysis rates (s-1) 
+      real press(nlayermx)    ! pressure (hpa)
+      real t(nlayermx)        ! temperature (k)
+      real sza                ! solar zenith angle (deg)
+      real dist_sol           ! sun distance (au) 
+c
+c     reaction rates
+c
+      real a001(nlayermx), a002(nlayermx), a003(nlayermx)
+      real b001(nlayermx), b002(nlayermx), b003(nlayermx), 
+     $     b004(nlayermx), b005(nlayermx), b006(nlayermx)
+      real c001(nlayermx), c002(nlayermx), c003(nlayermx), 
+     $     c004(nlayermx), c005(nlayermx), c006(nlayermx), 
+     $     c007(nlayermx), c008(nlayermx), c009(nlayermx), 
+     $     c010(nlayermx), c011(nlayermx), c012(nlayermx),
+     $     c013(nlayermx), c014(nlayermx), c015(nlayermx), 
+     $     c016(nlayermx), c017(nlayermx), c018(nlayermx)
+      real d001(nlayermx), d002(nlayermx), d003(nlayermx)
+      real e001(nlayermx), e002(nlayermx)
+      real h001(nlayermx), h002(nlayermx)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer HETERO
+      parameter (HETERO=0)
+
+      integer iesp, iter, l, niter
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2, i_hox, i_ox,
+     $        i_o1d, i_o, i_o3, i_h, i_oh, i_ho2, i_n2
+      integer j_o2_o, j_o2_o1d, j_co2_o, j_co2_o1d,
+     $        j_o3_o1d, j_o3_o, j_h2o, j_hdo, j_h2o2,
+     $        j_ho2, j_no2
+c
+      parameter (niter = 5)          ! iterations in the chemical scheme
+c
+      real*8 cc0(nlayermx,nesp)        ! initial number density (cm-3)
+      real*8 cc(nlayermx,nesp)         ! final number density (cm-3)
+      real*8 co2(nlayermx)             ! co2 number density (cm-3)
+      real*8 nox(nlayermx)             ! nox number density (cm-3)
+      real*8 no(nlayermx)              ! no  number density (cm-3)
+      real*8 no2(nlayermx)             ! no2 number density (cm-3)
+      real*8 production(nlayermx,nesp) ! production rate
+      real*8 loss(nlayermx,nesp)       ! loss rate
+c
+      real c007h(nlayermx)           ! c007 rate modified
+c                                    ! by heterogenous reactions h001 and h002
+c
+      real ro_o3, rh_ho2, roh_ho2, rno2_no
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracer numbering in the chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2    =  1
+      i_co     =  2
+      i_o      =  3
+      i_o1d    =  4
+      i_o2     =  5
+      i_o3     =  6
+      i_h      =  7
+      i_h2     =  8
+      i_oh     =  9
+      i_ho2    = 10 
+      i_h2o2   = 11
+      i_h2o    = 12
+      i_n2     = 13
+      i_hox    = 14
+      i_ox     = 15
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     numbering of photolysis rates
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      j_o2_o     =  1      ! o2 + hv   -> o + o
+      j_o2_o1d   =  2      ! o2 + hv   -> o + o(1d)
+      j_co2_o    =  3      ! co2 + hv  -> co + o
+      j_co2_o1d  =  4      ! co2 + hv  -> co + o(1d)
+      j_o3_o1d   =  5      ! o3 + hv   -> o2 + o(1d)
+      j_o3_o     =  6      ! o3 + hv   -> o2 + o
+      j_h2o      =  7      ! h2o + hv  -> h + oh
+      j_hdo      =  8      ! hdo + hv  -> d + oh
+      j_h2o2     =  9      ! h2o2 + hv -> oh + oh
+      j_ho2      =  10     ! ho2 + hv  -> oh + o
+      j_no2      =  11     ! no2 + hv  -> no + o
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     volume mixing ratio -> density conversion
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do iesp = 1,nesp
+         do l = 1,lswitch-1
+            cc0(l,iesp) = rm(l,iesp)*dens(l)
+            cc(l,iesp)  = cc0(l,iesp)
+         end do
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     co2 and nox number densities (cm-3)    
+c      
+c     co2 mixing ratio: 0.953
+c     nox mixing ratio: 6.e-10 (yung and demore, 1999)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+         co2(l) = cc(l,i_co2)
+         nox(l) = 6.e-10*dens(l)
+      end do 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     loop over iterations in the chemical scheme
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do iter = 1,niter
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     modification of c007
+c        by heterogenous reactions h001 and h002
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      if (HETERO.eq.1) then
+       do l = 1,lswitch-1
+         c007h(l) = c007(l)
+     $            + h001(l)/max(cc(l,i_oh), 1.e-30*dens(l))
+     $            + h002(l)/max(cc(l,i_ho2),1.e-30*dens(l))
+c         write(*,*) "C007 = ",c007(l)," / C007H = ",c007h(l)
+       end do
+      else
+       do l = 1,lswitch-1
+         c007h(l) = c007(l)
+       end do
+      endif
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        nox species
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        no2/no
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+c
+         rno2_no = (d002(l)*cc(l,i_o3) + d003(l)*cc(l,i_ho2))
+     $            /(j(l,j_no2) +
+     $              d001(l)*max(cc(l,i_o),1.e-30*dens(l)))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        no
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         no(l) = nox(l)/(1. + rno2_no)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        no2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         no2(l) = no(l)*rno2_no
+c
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        hox species
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        photochemical equilibrium for oh and ho2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        h/ho2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+c
+         rh_ho2 = (c001(l)*cc(l,i_o)
+     $           + c004(l)*cc(l,i_h)
+     $           + c005(l)*cc(l,i_h)
+     $           + c006(l)*cc(l,i_h)
+     $           + c007h(l)*cc(l,i_oh)
+     $           + 2.*c008(l)*cc(l,i_ho2)
+     $           + c015(l)*cc(l,i_o3)
+     $           + 2.*c016(l)*cc(l,i_ho2)
+     $           + j(l,j_ho2))
+     $          /(c011(l)*cc(l,i_o2))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        oh/ho2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         roh_ho2 = (c001(l)*cc(l,i_o)
+     $            + c003(l)*cc(l,i_o3)*rh_ho2
+     $            + 2.*c004(l)*cc(l,i_h)
+     $            + 2.*c008(l)*cc(l,i_ho2)
+     $            + c015(l)*cc(l,i_o3)
+     $            + d003(l)*no(l)
+     $            + j(l,j_ho2)
+     $            + j(l,j_h2o)*cc(l,i_h2o)
+     $             /max(cc(l,i_ho2),dens(l)*1.e-30))
+     $            /(c002(l)*cc(l,i_o)
+     $            + c007h(l)*cc(l,i_ho2)
+     $            + e001(l)*cc(l,i_co))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        h
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         cc(l,i_h) = cc(l,i_hox)
+     $                 /(1. + (1. + roh_ho2)/rh_ho2)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        ho2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         cc(l,i_ho2) = cc(l,i_h)/rh_ho2
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        oh
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         cc(l,i_oh) = cc(l,i_ho2)*roh_ho2
+c
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     modification of c007
+c        by heterogenous reactions h001 and h002
+c           after update of cc(l,i_oh) and cc(l,i_ho2)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      if (HETERO.eq.1) then
+       do l = 1,lswitch-1
+         c007h(l) = c007(l)
+     $            + h001(l)/max(cc(l,i_oh), 1.e-30*dens(l))
+     $            + h002(l)/max(cc(l,i_ho2),1.e-30*dens(l))
+c         write(*,*) "C007 = ",c007(l)," / C007H = ",c007h(l)
+       end do
+      endif
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        ox species
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        day:
+c        - o1d at photochemical equilibrium 
+c        - o3 at photochemical equilibrium
+c        - continuity equation for ox
+c        night:
+c        - o1d = 0
+c        - continuity equation for o3
+c        - continuity equation for o
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        
+      if (sza .le. 95.) then
+c
+         do l = 1,lswitch-1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o(1d)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            cc(l,i_o1d) = (j(l,j_co2_o1d)*co2(l)
+     $                   + j(l,j_o2_o1d)*cc(l,i_o2)
+     $                   + j(l,j_o3_o1d)*cc(l,i_o3))
+     $                   /( b001(l)*co2(l)
+     $                   + b002(l)*cc(l,i_h2o)
+     $                   + b003(l)*cc(l,i_h2)
+     $                   + b004(l)*cc(l,i_o2)
+     $                   + b005(l)*cc(l,i_o3)
+     $                   + b006(l)*cc(l,i_o3))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o/o3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            ro_o3 = (j(l,j_o3_o1d) + j(l,j_o3_o)
+     $              + a003(l)*cc(l,i_o)
+     $              + c003(l)*cc(l,i_h)
+     $              + c014(l)*cc(l,i_oh)
+     $              + c015(l)*cc(l,i_ho2))
+     $              /(a001(l)*cc(l,i_o2))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            cc(l,i_o3) = cc(l,i_ox)/(1. + ro_o3)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            cc(l,i_o) = cc(l,i_o3)*ro_o3
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        ox = o + o3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            production(l,i_ox) =
+     $                   + j(l,j_co2_o)*co2(l)
+     $                   + j(l,j_co2_o1d)*co2(l)
+     $                   + j(l,j_ho2)*cc(l,i_ho2)
+     $                   + 2.*j(l,j_o2_o)*cc(l,i_o2)
+     $                   + 2.*j(l,j_o2_o1d)*cc(l,i_o2)
+     $                   + c006(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                   + c013(l)*cc(l,i_oh)*cc(l,i_oh)
+     $                   + d003(l)*cc(l,i_ho2)*no(l)
+c
+            loss(l,i_ox) = 2.*a002(l)*cc(l,i_o)*cc(l,i_o)
+     $                   + 2.*a003(l)*cc(l,i_o)*cc(l,i_o3)
+     $                   + c001(l)*cc(l,i_ho2)*cc(l,i_o)
+     $                   + c002(l)*cc(l,i_oh)*cc(l,i_o)
+     $                   + c003(l)*cc(l,i_h)*cc(l,i_o3)
+     $                   + c012(l)*cc(l,i_o)*cc(l,i_h2o2)
+     $                   + c014(l)*cc(l,i_o3)*cc(l,i_oh)
+     $                   + c015(l)*cc(l,i_o3)*cc(l,i_ho2)
+     $                   + d001(l)*cc(l,i_o)*no2(l)
+     $                   + e002(l)*cc(l,i_o)*cc(l,i_co)
+c
+            loss(l,i_ox) = loss(l,i_ox)/cc(l,i_ox)
+c
+         end do
+c
+      else
+c
+         do l = 1,lswitch-1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o(1d)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            cc(l,i_o1d) = 0.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o3
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            production(l,i_o3) = a001(l)*cc(l,i_o2)*cc(l,i_o)
+c
+            loss(l,i_o3) = a003(l)*cc(l,i_o)
+     $                   + c003(l)*cc(l,i_h)
+     $                   + c014(l)*cc(l,i_oh)
+     $                   + c015(l)*cc(l,i_ho2)
+c
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+            production(l,i_o) = c006(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                        + c013(l)*cc(l,i_oh)*cc(l,i_oh)
+c
+            loss(l,i_o)  =  a001(l)*cc(l,i_o2)
+     $                   + 2.*a002(l)*cc(l,i_o)
+     $                   + a003(l)*cc(l,i_o3)
+     $                   + c001(l)*cc(l,i_ho2)
+     $                   + c002(l)*cc(l,i_oh)
+     $                   + c012(l)*cc(l,i_h2o2)
+     $                   + e002(l)*cc(l,i_co)
+c
+         end do
+      end if
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     other species
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        co
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_co) = j(l,j_co2_o)*co2(l)
+     $                      + j(l,j_co2_o1d)*co2(l)
+c
+         loss(l,i_co) = e001(l)*cc(l,i_oh)
+     $                + e002(l)*cc(l,i_o)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        o2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_o2) = 
+     $                  j(l,j_o3_o)*cc(l,i_o3)
+     $                + j(l,j_o3_o1d)*cc(l,i_o3)
+     $                + a002(l)*cc(l,i_o)*cc(l,i_o)
+     $                + 2.*a003(l)*cc(l,i_o)*cc(l,i_o3)
+     $                + 2.*b005(l)*cc(l,i_o1d)*cc(l,i_o3)
+     $                + b006(l)*cc(l,i_o1d)*cc(l,i_o3)
+     $                + c001(l)*cc(l,i_o)*cc(l,i_ho2)
+     $                + c002(l)*cc(l,i_o)*cc(l,i_oh)
+     $                + c003(l)*cc(l,i_h)*cc(l,i_o3)
+     $                + c005(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                + c007h(l)*cc(l,i_oh)*cc(l,i_ho2)
+     $                + c008(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                + c014(l)*cc(l,i_o3)*cc(l,i_oh)
+     $                + 2.*c015(l)*cc(l,i_o3)*cc(l,i_ho2)
+     $                + c016(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                + d001(l)*cc(l,i_o)*no2(l)
+c
+         loss(l,i_o2) = j(l,j_o2_o)
+     $                + j(l,j_o2_o1d)
+     $                + a001(l)*cc(l,i_o)
+     $                + c011(l)*cc(l,i_h)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        h2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_h2) = c005(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                      + c018(l)*cc(l,i_h)*cc(l,i_h)
+c
+         loss(l,i_h2) = b003(l)*cc(l,i_o1d)
+     $                + c010(l)*cc(l,i_oh)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        h2o
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_h2o) = 
+     $                   c006(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                 + c007h(l)*cc(l,i_oh)*cc(l,i_ho2)
+     $                 + c009(l)*cc(l,i_oh)*cc(l,i_h2o2)
+     $                 + c010(l)*cc(l,i_oh)*cc(l,i_h2)
+     $                 + c013(l)*cc(l,i_oh)*cc(l,i_oh)
+c
+         loss(l,i_h2o) = j(l,j_h2o)
+     $                 + b002(l)*cc(l,i_o1d)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        h2o2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_h2o2) =
+     $                    c008(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                  + c016(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                  + c017(l)*cc(l,i_oh)*cc(l,i_oh)
+c
+         loss(l,i_h2o2) = j(l,j_h2o2)
+     $                  + c009(l)*cc(l,i_oh)
+     $                  + c012(l)*cc(l,i_o)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        hox = h + oh + ho2
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+         production(l,i_hox) = 
+     $                   2.*j(l,j_h2o)*cc(l,i_h2o)
+     $                 + 2.*j(l,j_h2o2)*cc(l,i_h2o2)
+     $                 + 2.*b002(l)*cc(l,i_o1d)*cc(l,i_h2o)
+     $                 + 2.*b003(l)*cc(l,i_o1d)*cc(l,i_h2)
+     $                 + 2.*c012(l)*cc(l,i_o)*cc(l,i_h2o2)
+c
+         loss(l,i_hox) = 2.*c005(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                 + 2.*c006(l)*cc(l,i_h)*cc(l,i_ho2)
+     $                 + 2.*c007h(l)*cc(l,i_oh)*cc(l,i_ho2)
+     $                 + 2.*c008(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                 + 2.*c013(l)*cc(l,i_oh)*cc(l,i_oh)
+     $                 + 2.*c016(l)*cc(l,i_ho2)*cc(l,i_ho2)
+     $                 + 2.*c017(l)*cc(l,i_oh)*cc(l,i_oh)
+     $                 + 2.*c018(l)*cc(l,i_h)*cc(l,i_h)
+c
+         loss(l,i_hox) = loss(l,i_hox)/cc(l,i_hox)
+c
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     update number densities
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     long-lived species
+c
+      do l = 1,lswitch-1
+         cc(l,i_co)  = (cc0(l,i_co) + production(l,i_co)*dt)
+     $              /(1. + loss(l,i_co)*dt)
+         cc(l,i_o2)  = (cc0(l,i_o2) + production(l,i_o2)*dt)
+     $              /(1. + loss(l,i_o2)*dt)
+         cc(l,i_h2)  = (cc0(l,i_h2) + production(l,i_h2)*dt)
+     $              /(1. + loss(l,i_h2)*dt)
+         cc(l,i_h2o2)= (cc0(l,i_h2o2) + production(l,i_h2o2)*dt)
+     $              /(1. + loss(l,i_h2o2)*dt)
+         cc(l,i_h2o) = (cc0(l,i_h2o) + production(l,i_h2o)*dt)
+     $              /(1. + loss(l,i_h2o)*dt)
+         cc(l,i_hox) = (cc0(l,i_hox) + production(l,i_hox)*dt)
+     $              /(1. + loss(l,i_hox)*dt)
+      end do
+c
+c     ox species
+c
+      if (sza .le. 95.) then
+         do l = 1,lswitch-1
+            cc(l,i_ox) = (cc0(l,i_ox) + production(l,i_ox)*dt)
+     $                   /(1. + loss(l,i_ox)*dt)
+         end do
+      else
+         do l = 1,lswitch-1
+            cc(l,i_o)  = (cc0(l,i_o) + production(l,i_o)*dt)
+     $                   /(1. + loss(l,i_o)*dt)
+            cc(l,i_o3) = (cc0(l,i_o3) + production(l,i_o3)*dt)
+     $                   /(1. + loss(l,i_o3)*dt)
+            cc(l,i_ox) = cc(l,i_o) + cc(l,i_o3)
+         end do
+      end if 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     end of loop over iterations
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      end do
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     density -> volume mixing ratio conversion
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do iesp = 1,nesp
+         do l = 1,lswitch-1
+            rm(l,iesp) = max(cc(l,iesp)/dens(l), 1.e-30)
+         end do
+      end do
+c
+      return
+      end
+c
+c*****************************************************************
+c
+      subroutine phot(lswitch, press, temp, sza, dist_sol, rmo3, j)
+c
+c*****************************************************************
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "chimiedata.h" 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c       
+      integer lswitch         ! interface level between chemistries
+      real press(nlayermx)             ! pressure (hPa)
+      real temp(nlayermx)              ! temperature (K)
+      real sza                         ! solar zenith angle (deg)
+      real dist_sol                    ! sun distance (AU) 
+      real rmo3(nlayermx)              ! ozone mixing ratio
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     output:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      real j(nlayermx,nd)              ! interpolated photolysis rates (s-1) 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer icol, ij, indsza, indcol, indozo, indtemp, 
+     $        iozo, isza, it, iztop, l
+c
+      real col(nlayermx)               ! overhead air column   (molecule cm-2)
+      real colo3(nlayermx)             ! overhead ozone column (molecule cm-2)
+      real poids(2,2,2,2)              ! 4D interpolation weights 
+      real tref                        ! temperature  at 1.9 hPa in the gcm (K)
+      real table_temp(ntemp)           ! temperatures at 1.9 hPa in jmars   (K)
+      real cinf, csup, cicol, 
+     $     ciozo, cisza, citemp
+      real colo3min, dp, scaleh
+      real ratio_o3(nlayermx)
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     day/night criterion
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      if (sza .le. 95.) then 
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     temperatures at 1.9 hPa in jmars
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      table_temp(1) = 226.2
+      table_temp(2) = 206.2
+      table_temp(3) = 186.2
+      table_temp(4) = 169.8
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     interpolation in solar zenith angle
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      indsza = nsza - 1
+      do isza = 1,nsza
+         if (szatab(isza) .ge. sza) then
+            indsza = min(indsza,isza - 1)
+            indsza = max(indsza, 1)
+         end if
+      end do
+      cisza = (sza - szatab(indsza))
+     $       /(szatab(indsza + 1) - szatab(indsza))
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     air and ozone columns
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     air column at model top: assign standard value
+c
+      scaleh = 10.
+      iztop = nint(scaleh*log(press(1)/press(lswitch-1)))
+      iztop = min(iztop,200)
+      col(lswitch-1) = colairtab(iztop)
+c
+c     ozone column at model top
+c
+      colo3(lswitch-1) = 0.
+c
+c     air and ozone columns for other levels
+c
+      do l = lswitch-2,1,-1
+         dp = (press(l) - press(l+1))*100.
+         col(l) = col(l+1) + factor*dp
+         col(l) = min(col(l), colairtab(0))
+         colo3(l) = colo3(l+1)
+     $            + factor*(rmo3(l+1) + rmo3(l))*0.5*dp
+      end do
+c
+c     ratio ozone column/minimal theoretical column (ro3 = 7.171e-10)
+c
+      do l = 1,lswitch-1
+         colo3min    = col(l)*7.171e-10
+         ratio_o3(l) = colo3(l)/colo3min
+         ratio_o3(l) = min(ratio_o3(l), table_ozo(nozo)*10.)
+         ratio_o3(l) = max(ratio_o3(l), table_ozo(1)*10.)
+      end do
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     temperature dependence
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     1) search for temperature at 1.9 hPa (tref): vertical interpolation
+c
+c      print*,'****** recherche de T a 1.9 hPa ******'
+      tref = temp(1)
+      do l = (lswitch-1)-1,1,-1
+         if (press(l) .gt. 1.9) then
+            cinf = (press(l) - 1.9)
+     $            /(press(l) - press(l+1))
+            csup = 1. - cinf
+            tref = cinf*temp(l+1) + csup*temp(l)
+c
+c            print*, press(l+1), temp(l+1)
+c            print*, press(l  ), temp(l  )
+c            print*, 'tref = ', tref
+            go to 10
+         end if
+      end do 
+ 10   continue
+c
+c     2) interpolation in temperature
+c
+      tref = min(tref,table_temp(1))
+      tref = max(tref,table_temp(ntemp))
+c
+      do it = 2, ntemp
+         if (table_temp(it) .le. tref) then
+            citemp = (log(tref) - log(table_temp(it)))
+     $              /(log(table_temp(it-1)) - log(table_temp(it)))
+            indtemp = it - 1
+c            print*,'interpolation entre ', table_temp(it), ' et ',
+c     $              table_temp(it-1) 
+c            print*,'indtemp = ', indtemp, ' citemp = ', citemp
+            goto 20
+         end if
+      end do
+  20  continue
+c      print*,'****** fin interpolation en T ********'
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     loop over vertical levels
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+c
+c     interpolation in air column
+c
+         do icol = 0,200
+            if (colairtab(icol) .lt. col(l)) then
+               cicol = (log(col(l)) - log(colairtab(icol)))
+     $                /(log(colairtab(icol-1)) - log(colairtab(icol)))
+               indcol = icol - 1
+               goto 30
+            end if
+         end do
+ 30      continue
+c
+cc    interpolation in ozone column
+c
+         indozo = nozo - 1
+         do iozo = 1,nozo
+            if (table_ozo(iozo)*10. .ge. ratio_o3(l)) then
+               indozo = min(indozo, iozo - 1)
+               indozo = max(indozo, 1)
+            end if
+         end do
+         ciozo = (ratio_o3(l) - table_ozo(indozo)*10.)
+     $          /(table_ozo(indozo + 1)*10. - table_ozo(indozo)*10.)
+c
+c         write(6,'(i2,4e13.4,5f10.4)') 
+c    $         l, press(l), col(l), 
+c    $         colairtab(indcol), colairtab(indcol+1), 
+c    $         colo3(l)/2.687e15, 
+c    $         ratio_o3(l), table_ozo(indozo), table_ozo(indozo+1), 
+c    $         ciozo
+c 
+cc    4-dimensional interpolation weights
+c
+         poids(1,1,1,1) = citemp*(1.-cisza)*cicol*(1.-ciozo)
+         poids(1,1,1,2) = citemp*(1.-cisza)*cicol*ciozo
+         poids(1,1,2,1) = citemp*(1.-cisza)*(1.-cicol)*(1.-ciozo)
+         poids(1,1,2,2) = citemp*(1.-cisza)*(1.-cicol)*ciozo
+         poids(1,2,1,1) = citemp*cisza*cicol*(1.-ciozo)
+         poids(1,2,1,2) = citemp*cisza*cicol*ciozo
+         poids(1,2,2,1) = citemp*cisza*(1.-cicol)*(1.-ciozo)
+         poids(1,2,2,2) = citemp*cisza*(1.-cicol)*ciozo
+         poids(2,1,1,1) = (1.-citemp)*(1.-cisza)*cicol*(1.-ciozo)
+         poids(2,1,1,2) = (1.-citemp)*(1.-cisza)*cicol*ciozo
+         poids(2,1,2,1) = (1.-citemp)*(1.-cisza)*(1.-cicol)*(1.-ciozo)
+         poids(2,1,2,2) = (1.-citemp)*(1.-cisza)*(1.-cicol)*ciozo
+         poids(2,2,1,1) = (1.-citemp)*cisza*cicol*(1.-ciozo)
+         poids(2,2,1,2) = (1.-citemp)*cisza*cicol*ciozo
+         poids(2,2,2,1) = (1.-citemp)*cisza*(1.-cicol)*(1.-ciozo)
+         poids(2,2,2,2) = (1.-citemp)*cisza*(1.-cicol)*ciozo
+c
+cc    4-dimensional interpolation in the lookup table
+c
+         do ij = 1,nd
+           j(l,ij) =
+     $     poids(1,1,1,1)*jphot(indtemp,indsza,indcol,indozo,ij)
+     $   + poids(1,1,1,2)*jphot(indtemp,indsza,indcol,indozo+1,ij)
+     $   + poids(1,1,2,1)*jphot(indtemp,indsza,indcol+1,indozo,ij)
+     $   + poids(1,1,2,2)*jphot(indtemp,indsza,indcol+1,indozo+1,ij)
+     $   + poids(1,2,1,1)*jphot(indtemp,indsza+1,indcol,indozo,ij)
+     $   + poids(1,2,1,2)*jphot(indtemp,indsza+1,indcol,indozo+1,ij)
+     $   + poids(1,2,2,1)*jphot(indtemp,indsza+1,indcol+1,indozo,ij)
+     $   + poids(1,2,2,2)*jphot(indtemp,indsza+1,indcol+1,indozo+1,ij)
+     $   + poids(2,1,1,1)*jphot(indtemp+1,indsza,indcol,indozo,ij)
+     $   + poids(2,1,1,2)*jphot(indtemp+1,indsza,indcol,indozo+1,ij)
+     $   + poids(2,1,2,1)*jphot(indtemp+1,indsza,indcol+1,indozo,ij)
+     $   + poids(2,1,2,2)*jphot(indtemp+1,indsza,indcol+1,indozo+1,ij)
+     $   + poids(2,2,1,1)*jphot(indtemp+1,indsza+1,indcol,indozo,ij)
+     $   + poids(2,2,1,2)*jphot(indtemp+1,indsza+1,indcol,indozo+1,ij)
+     $   + poids(2,2,2,1)*jphot(indtemp+1,indsza+1,indcol+1,indozo,ij)
+     $   + poids(2,2,2,2)*jphot(indtemp+1,indsza+1,indcol+1,indozo+1,ij)
+         end do
+c
+cc    correction for sun distance
+c
+         do ij = 1,nd
+            j(l,ij) = j(l,ij)*(1.52/dist_sol)**2.
+         end do 
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     end of loop over vertical levels
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      end do
+c
+      else
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     night
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do ij = 1,nd
+         do l = 1,lswitch-1
+            j(l,ij) = 0.
+         end do
+      end do
+c
+      end if
+c
+      return
+      end
+c
+c*****************************************************************
+c
+      subroutine gcmtochim(zycol, lswitch, nesp, rm)
+c
+c*****************************************************************
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      real zycol(nlayermx,nqmx)! species volume mixing ratio in the gcm
+c
+      integer nesp            ! number of species in the chemistry
+      integer lswitch         ! interface level between chemistries
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     outputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      real rm(nlayermx,nesp)   ! species volume mixing ratio 
+c      
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer l
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2, i_hox, i_ox,
+     $        i_o1d, i_o, i_o3, i_h, i_oh, i_ho2, i_n2
+c      
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     co2      =  nqchem_min           
+c     co       =  nqchem_min + 1          
+c     o        =  nqchem_min + 2
+c     o(1d)    =  nqchem_min + 3
+c     o2       =  nqchem_min + 4
+c     o3       =  nqchem_min + 5
+c     h        =  nqchem_min + 6
+c     h2       =  nqchem_min + 7
+c     oh       =  nqchem_min + 8
+c     ho2      =  nqchem_min + 9
+c     h2o2     =  nqchem_min + 10
+c     n2       =  nqchem_min + 11
+c     ar       =  nqchem_min + 12
+c     h2o      =  nqmx
+c      
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2    =  1
+      i_co     =  2
+      i_o      =  3
+      i_o1d    =  4
+      i_o2     =  5
+      i_o3     =  6
+      i_h      =  7
+      i_h2     =  8
+      i_oh     =  9
+      i_ho2    = 10
+      i_h2o2   = 11
+      i_h2o    = 12
+      i_n2     = 13
+      i_hox    = 14
+      i_ox     = 15
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     initialise chemical species
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+       rm(l,i_co2)  = max(zycol(l, nqchem_min),      1.e-30)
+       rm(l,i_co)   = max(zycol(l, nqchem_min + 1),  1.e-30)
+       rm(l,i_o)    = max(zycol(l, nqchem_min + 2),  1.e-30)
+       rm(l,i_o1d)  = max(zycol(l, nqchem_min + 3),  1.e-30)
+       rm(l,i_o2)   = max(zycol(l, nqchem_min + 4),  1.e-30)
+       rm(l,i_o3)   = max(zycol(l, nqchem_min + 5),  1.e-30)
+       rm(l,i_h)    = max(zycol(l, nqchem_min + 6),  1.e-30)
+       rm(l,i_h2)   = max(zycol(l, nqchem_min + 7),  1.e-30)
+       rm(l,i_oh)   = max(zycol(l, nqchem_min + 8),  1.e-30)
+       rm(l,i_ho2)  = max(zycol(l, nqchem_min + 9),  1.e-30)
+       rm(l,i_h2o2) = max(zycol(l, nqchem_min + 10), 1.e-30)
+       rm(l,i_n2)   = max(zycol(l, nqchem_min + 11), 1.e-30)
+       rm(l,i_h2o)  = max(zycol(l, nqmx),            1.e-30)
+c 
+      end do 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     initialise chemical families                     c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+         rm(l,i_hox) = rm(l,i_h) 
+     $               + rm(l,i_oh)
+     $               + rm(l,i_ho2)
+         rm(l,i_ox)  = rm(l,i_o) 
+     $               + rm(l,i_o3)
+      end do
+c
+      return
+      end
+c
+c*****************************************************************
+c
+      subroutine chimtogcm(zycol, lswitch, nesp, rm)
+c
+c*****************************************************************
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer nesp               ! number of species in the chemistry
+      integer lswitch            ! interface level between chemistries
+c      
+      real rm(nlayermx,nesp)     ! species volume mixing ratio 
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     output:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c      
+      real zycol(nlayermx,nqmx)  ! species volume mixing ratio in the gcm
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer l
+      integer i_co2, i_co, i_o2, i_h2, i_h2o, i_h2o2, i_hox, i_ox,
+     $        i_o1d, i_o, i_o3, i_h, i_oh, i_ho2, i_n2
+c      
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c     co2      =  nqchem_min
+c     co       =  nqchem_min + 1
+c     o        =  nqchem_min + 2
+c     o(1d)    =  nqchem_min + 3
+c     o2       =  nqchem_min + 4
+c     o3       =  nqchem_min + 5
+c     h        =  nqchem_min + 6
+c     h2       =  nqchem_min + 7
+c     oh       =  nqchem_min + 8
+c     ho2      =  nqchem_min + 9
+c     h2o2     =  nqchem_min + 10
+c     n2       =  nqchem_min + 11
+c     ar       =  nqchem_min + 12
+c     h2o      =  nqmx
+c      
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     tracers numbering in the chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      i_co2    =  1
+      i_co     =  2
+      i_o      =  3
+      i_o1d    =  4
+      i_o2     =  5
+      i_o3     =  6
+      i_h      =  7
+      i_h2     =  8
+      i_oh     =  9
+      i_ho2    = 10
+      i_h2o2   = 11
+      i_h2o    = 12
+      i_n2     = 13
+      i_hox    = 14
+      i_ox     = 15
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     save mixing ratios for the gcm
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+         zycol(l, nqchem_min)      = rm(l,i_co2) 
+         zycol(l, nqchem_min + 1)  = rm(l,i_co) 
+         zycol(l, nqchem_min + 2)  = rm(l,i_o) 
+         zycol(l, nqchem_min + 3)  = rm(l,i_o1d)
+         zycol(l, nqchem_min + 4)  = rm(l,i_o2) 
+         zycol(l, nqchem_min + 5)  = rm(l,i_o3) 
+         zycol(l, nqchem_min + 6)  = rm(l,i_h)  
+         zycol(l, nqchem_min + 7)  = rm(l,i_h2) 
+         zycol(l, nqchem_min + 8)  = rm(l,i_oh) 
+         zycol(l, nqchem_min + 9)  = rm(l,i_ho2) 
+         zycol(l, nqchem_min + 10) = rm(l,i_h2o2)
+         zycol(l, nqchem_min + 11) = rm(l,i_n2)
+         zycol(l, nqmx)            = rm(l,i_h2o)
+      end do 
+c
+c  water ice: zycol(nqmx-1) has not been changed if iceparty on
+c  
+      return
+      end
+c
+c*****************************************************************
+c
+      subroutine chemrates(lswitch, dens, press, t, icesurf,
+     $                     a001, a002, a003,
+     $                     b001, b002, b003, b004, b005, b006,
+     $                     c001, c002, c003, c004, c005, c006,
+     $                     c007, c008, c009, c010, c011, c012,
+     $                     c013, c014, c015, c016, c017, c018,
+     $                     d001, d002, d003,
+     $                     e001, e002,
+     $                     h001, h002)
+c
+c*****************************************************************
+c
+      implicit none
+c
+#include "dimensions.h"
+#include "dimphys.h"
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     inputs:                                                    c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      integer lswitch                  ! interface level between chemistries
+
+      real dens(nlayermx)              ! density (cm-3)
+      real press(nlayermx)             ! pressure (hpa)
+      real t(nlayermx)                 ! temperature (k)
+      real icesurf(nlayermx)           ! ice surface area (cm^2/cm^3)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     outputs:                                                   c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      real a001(nlayermx), a002(nlayermx), a003(nlayermx)
+      real b001(nlayermx), b002(nlayermx), b003(nlayermx), 
+     $     b004(nlayermx), b005(nlayermx), b006(nlayermx)
+      real c001(nlayermx), c002(nlayermx), c003(nlayermx), 
+     $     c004(nlayermx), c005(nlayermx), c006(nlayermx), 
+     $     c007(nlayermx), c008(nlayermx), c009(nlayermx), 
+     $     c010(nlayermx), c011(nlayermx), c012(nlayermx),
+     $     c013(nlayermx), c014(nlayermx), c015(nlayermx), 
+     $     c016(nlayermx), c017(nlayermx), c018(nlayermx)
+      real d001(nlayermx), d002(nlayermx), d003(nlayermx)
+      real e001(nlayermx), e002(nlayermx)
+      real h001(nlayermx), h002(nlayermx)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     local:                                                     c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      real ak0, ak1, rate, xpo
+c
+      integer l
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c     compute reaction rates from JPL 1997, otherwise mentioned
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+      do l = 1,lswitch-1
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        oxygen compounds
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      a001: o + o2 + co2 -> o3 + co2
+c
+c        jpl 2003
+c
+         a001(l) = 2.5
+     $             *6.0e-34*(t(l)/300.)**(-2.4)*dens(l)
+c
+c        nair et al., 1994
+c
+c        a001(l) = 1.3e-34*exp(724./t(l))*dens(l)
+c
+ccc      a002: o + o + co2 -> o2 + co2
+c
+c        Tsang and Hampson, J. Chem. Phys. Ref. Data, 15, 1087, 1986
+c
+         a002(l) = 2.5*5.2e-35*exp(900./t(l))*dens(l)
+c
+c        Campbell and Gray, Chem. Phys. Lett., 18, 607, 1973
+c
+c        a002(l) = 1.2e-32*(300./t(l))**(2.0)*dens(l)
+c
+ccc      a003: o + o3 -> o2 + o2
+c
+c        jpl 2003
+c
+         a003(l) = 8.0e-12*exp(-2060./t(l))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        reactions with o(1d)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      b001: o(1d) + co2  -> o + co2
+c
+c        jpl 2003
+c
+         b001(l) = 7.4e-11*exp(120./t(l))
+c
+ccc      b002: o(1d) + h2o  -> oh + oh
+c
+c        jpl 2003
+c
+         b002(l) = 2.2e-10
+c    
+ccc      b003: o(1d) + h2  -> oh + h
+c
+c        jpl 2003
+c
+         b003(l) = 1.1e-10
+c
+c        nair et al., 1994
+c
+c        b003(l) = 1.0e-10
+c    
+ccc      b004: o(1d) + o2  -> o + o2
+c
+c        jpl 2003
+c
+         b004(l) = 3.2e-11*exp(70./t(l))
+c    
+ccc      b005: o(1d) + o3  -> o2 + o2
+c
+c        jpl 2003
+c
+         b005(l) = 1.2e-10
+c    
+ccc      b006: o(1d) + o3  -> o2 + o + o
+c
+c        jpl 2003
+c
+         b006(l) = 1.2e-10
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        hydrogen compounds    
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      c001: o + ho2 -> oh + o2
+c
+c        jpl 2003
+c 
+         c001(l) = 3.0e-11*exp(200./t(l))
+c        c001(l) = 0.75*3.0e-11*exp(200./t(l))
+c
+ccc      c002: o + oh -> o2 + h
+c
+c        jpl 2003
+c 
+         c002(l) = 2.2e-11*exp(120./t(l))
+c
+ccc      c003: h + o3 -> oh + o2
+c
+c        jpl 2003
+c 
+         c003(l) = 1.4e-10*exp(-470./t(l))
+c
+ccc      c004: h + ho2 -> oh + oh
+c
+c        jpl 2003
+c 
+         c004(l) = 8.1e-11*0.90
+c
+ccc      c005: h + ho2 -> h2 + o2
+c
+c        jpl 2003
+c 
+         c005(l) = 8.1e-11*0.08
+c
+ccc      c006: h + ho2 -> h2o + o
+c
+c        jpl 2003
+c 
+         c006(l) = 8.1e-11*0.02
+c
+ccc      c007: oh + ho2 -> h2o + o2
+c
+c        jpl 2003
+c 
+         c007(l) = 4.8e-11*exp(250./t(l))
+c        c007(l) = 0.75*4.8e-11*exp(250./t(l))
+c
+ccc      c008: ho2 + ho2 -> h2o2 + o2
+c
+c        jpl 2003
+c 
+c        c008(l) = 2.3e-13*exp(600./t(l))
+c
+c        christensen et al., grl, 13, 2002
+c
+         c008(l) = 1.5e-12*exp(19./t(l))
+c
+ccc      c009: oh + h2o2 -> h2o + ho2
+c
+c        jpl 2003
+c 
+         c009(l) = 2.9e-12*exp(-160./t(l))
+c
+ccc      c010: oh + h2 -> h2o + h
+c
+c        jpl 2003
+c 
+         c010(l) = 5.5e-12*exp(-2000./t(l))
+c
+ccc      c011: h + o2 + co2 -> ho2 + co2
+c
+c        jpl 2003
+c 
+         ak0 = 2.5*5.7e-32*(t(l)/300.)**(-1.6)
+         ak1 = 7.5e-11*(t(l)/300.)**(0.0)
+c
+         rate = (ak0*dens(l))/(1. + ak0*dens(l)/ak1)
+         xpo = 1./(1. + alog10((ak0*dens(l))/ak1)**2)
+         c011(l) = rate*0.6**xpo
+c
+ccc      c012: o + h2o2 -> oh + ho2
+c
+c        jpl 2003
+c 
+         c012(l) = 1.4e-12*exp(-2000./t(l))
+c
+ccc      c013: oh + oh -> h2o + o
+c
+c        jpl 2003
+c 
+         c013(l) = 4.2e-12*exp(-240./t(l))
+c
+ccc      c014: oh + o3 -> ho2 + o2
+c
+c        jpl 2003
+c
+         c014(l) = 1.7e-12*exp(-940./t(l))
+c
+c        jpl 2000
+c
+c        c014(l) = 1.5e-12*exp(-880./t(l))
+c
+c        nair et al., 1994 (jpl 1997)
+c
+c        c014(l) = 1.6e-12*exp(-940./t(l))
+c
+ccc      c015: ho2 + o3 -> oh + o2 + o2
+c
+c        jpl 2003
+c
+         c015(l) = 1.0e-14*exp(-490./t(l))
+c
+c        jpl 2000
+c
+c        c015(l) = 2.0e-14*exp(-680./t(l))
+c
+c        nair et al., 1994 (jpl 1997)
+c
+c        c015(l) = 1.1e-14*exp(-500./t(l))
+c
+ccc      c016: ho2 + ho2 + co2 -> h2o2 + o2 + co2
+c
+c        jpl 2003
+c
+         c016(l) = 2.5*1.7e-33
+     $              *exp(1000./t(l))*dens(l)
+c
+ccc      c017: oh + oh + co2 -> h2o2 + co2
+c
+c        jpl 2003
+c
+         ak0 = 2.5*6.9e-31*(t(l)/300.)**(-1.0)
+         ak1 = 2.6e-11*(t(l)/300.)**(0.0)
+c
+c        jpl 1997
+c
+c        ak0 = 2.5*6.2e-31*(t(l)/300.)**(-1.0)
+c        ak1 = 2.6e-11*(t(l)/300.)**(0.0)
+c
+c        nair et al., 1994
+c
+c        ak0 = 2.5*7.1e-31*(t(l)/300.)**(-0.8)
+c        ak1 = 1.5e-11*(t(l)/300.)**(0.0)
+c
+         rate = (ak0*dens(l))/(1. + ak0*dens(l)/ak1)
+         xpo = 1./(1. + alog10((ak0*dens(l))/ak1)**2)
+         c017(l) = rate*0.6**xpo
+c
+ccc      c018: h + h + co2 -> h2 + co2
+c
+c        baulch et al., 1992
+c
+         c018(l) = 2.5*8.85e-33*(t(l)/298.)**(-0.6)*dens(l)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        nitrogen compounds
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      d001: no2 + o -> no + o2
+c
+c        jpl 2003
+c
+         d001(l) = 5.6e-12*exp(180./t(l))
+c
+ccc      d002: no + o3 -> no2 + o2
+c
+c        jpl 2003
+c
+         d002(l) = 3.0e-12*exp(-1500./t(l))
+c
+ccc      d003: no + ho2 -> no2 + oh
+c
+c        jpl 2003
+c
+         d003(l) = 3.5e-12*exp(250./t(l))
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        carbon compounds
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      e001: oh + co -> co2 + h
+c
+c        jpl 2003
+c
+c        e001(l) = 1.5e-13*(1 + 0.6*press(l)/1013.)
+c
+c        mccabe et al., grl, 28, 3135, 2001
+c
+         e001(l) = 1.57e-13 + 3.54e-33*dens(l)
+c
+ccc      e002: o + co + m -> co2 + m
+c
+c        tsang and hampson, 1986.
+c
+         e002(l) = 2.5*6.5e-33*exp(-2184./t(l))*dens(l)
+c
+c        baulch et al., butterworths, 1976.
+c
+c        e002(l) = 1.6e-32*exp(-2184./t(l))*dens(l)
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        heterogenous chemistry
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+ccc      h001: ho2 + ice surface -> (ho2)ads
+ccc           (ho2)ads + oh -> h2o + o2
+ccc      total : oh + ho2 -> h2o + o2, first order
+ccc         K = h001*[ho2],
+ccc      h001 = (S*v*gamma1)/4. (s-1), v=100*sqrt(3kT/m_ho2) (cm s-1)
+c
+c        cooper and abbatt, 1996
+c
+         h001(l) = icesurf(l) * 25.*sqrt(3*8.31*t(l)/33.) * 0.025
+c         h001(l) = 0.0e0
+c
+ccc      h002: oh + ice surface -> (oh)ads
+ccc           (oh)ads + ho2 -> h2o + o2
+ccc      total : oh + ho2 -> h2o + o2, first order
+ccc         K = h002*[oh],
+ccc      h002 = (S*v*gamma2)/4. (s-1), v=100*sqrt(3kT/m_oh) (cm s-1)
+c
+c        cooper and abbatt, 1996
+c
+         h002(l) = icesurf(l) * 25.*sqrt(3*8.31*t(l)/17.) * 0.03
+c         h002(l) = 0.0e0
+c
+c        write(*,*) "level ",l," / icesurf=",icesurf(l),
+c     $       " / 0.25vg1=",(25.*sqrt(3*8.31*t(l)/33.) * 0.025),
+c     $       " / 0.25vg2=",(25.*sqrt(3*8.31*t(l)/17.) * 0.03)
+c
+      end do
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/thermosphere.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/thermosphere.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/aeronomars/thermosphere.F	(revision 57)
@@ -0,0 +1,88 @@
+      subroutine thermosphere(pplev,pplay,dist_sol,
+     $     mu0,ptimestep,ptime,zday,tsurf,zzlev,zzlay,
+     &     pt,pq,pu,pv,pdt,pdq,
+     $     zdteuv,zdtconduc,zdumolvis,zdvmolvis,zdqmoldiff)
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+#include "param.h"
+#include "param_v3.h"
+#include "chimiedata.h"
+#include "conc.h"
+
+
+      INTEGER l,ig
+
+      REAL pplay(ngridmx,nlayermx)
+      real pplev(ngridmx,nlayermx+1)
+      REAL zzlay(ngridmx,nlayermx)
+      real zzlev(ngridmx,nlayermx+1)
+      REAL pt(ngridmx,nlayermx)
+      real zday
+      REAL dist_sol
+      real mu0(ngridmx)
+      real pq(ngridmx,nlayermx,nqmx)
+      real ptimestep
+      real ptime
+      real tsurf(ngridmx)
+      REAL pu(ngridmx,nlayermx),pv(ngridmx,nlayermx)
+      REAL pdt(ngridmx,nlayermx),pdq(ngridmx,nlayermx,nqmx)
+
+      REAL zdteuv(ngridmx,nlayermx)
+      REAL zdtconduc(ngridmx,nlayermx)
+      REAL zdumolvis(ngridmx,nlayermx)
+      REAL zdvmolvis(ngridmx,nlayermx)
+      real zdqmoldiff(ngridmx,nlayermx,nqmx)
+
+      logical firstcall
+      save firstcall
+      data firstcall /.true./
+
+      if (firstcall) then
+        if (.not. tracer) then
+          do l=1,nlayermx
+            do ig=1,ngridmx
+              rnew(ig,l)=r
+              cpnew(ig,l)=cpp
+            enddo
+          enddo
+        endif
+        firstcall= .false.
+      endif
+
+      if (calleuv) then
+        call zerophys(ngridmx*nlayermx,zdteuv)
+        call euvheat(pt,pdt,pplev,pplay,zzlay,dist_sol,
+     $               mu0,ptimestep,ptime,zday,pq,pdq,zdteuv)
+      endif
+
+      if (callconduct) THEN
+        call zerophys(ngridmx*nlayermx,zdtconduc)
+        call conduction(ptimestep,pplay,pplev,pt,zdteuv,
+     $                   tsurf,zzlev,zzlay,zdtconduc)
+      endif
+
+      if (callmolvis) THEN
+        call zerophys(ngridmx*nlayermx,zdumolvis)
+        call molvis(ptimestep,pplay,pplev,pt,zdteuv,zdtconduc,pu,
+     $                   tsurf,zzlev,zzlay,zdumolvis)
+        call zerophys(ngridmx*nlayermx,zdvmolvis)
+        call molvis(ptimestep,pplay,pplev,pt,zdteuv,zdtconduc,pv,
+     $                   tsurf,zzlev,zzlay,zdvmolvis)
+      endif
+
+      if (callmoldiff) THEN
+        call zerophys(ngridmx*nlayermx*nqmx,zdqmoldiff)
+        call moldiff(pplay,pplev,pt,pdt,pq,pdq,ptimestep,
+     &                   zzlay,zdteuv,zdtconduc,zdqmoldiff)
+      endif
+
+      return
+      end
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cbrt.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cbrt.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cbrt.F	(revision 57)
@@ -0,0 +1,9 @@
+      FUNCTION cbrt(x)
+      IMPLICIT NONE
+
+      REAL x,cbrt
+
+      cbrt=sign(1.,x)*(abs(x)**(1./3.))
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgp.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgp.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgp.F	(revision 57)
@@ -0,0 +1,14 @@
+      FUNCTION cvmgp(x1,x2,x3)
+      IMPLICIT NONE
+
+      REAL x1,x2,x3,cvmgp
+
+      IF(x3.ge.0) then 
+        cvmgp=x1
+      ELSE
+        cvmgp=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgt.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgt.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/cvmgt.F	(revision 57)
@@ -0,0 +1,15 @@
+      FUNCTION cvmgt(x1,x2,l)
+      IMPLICIT NONE
+
+      REAL x1,x2,cvmgt
+      LOGICAL l
+
+      IF(l) then 
+        cvmgt=x1
+      ELSE
+        cvmgt=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/from36.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/from36.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/from36.F	(revision 57)
@@ -0,0 +1,111 @@
+      SUBROUTINE from36(x,nbre,iunit)
+      IMPLICIT NONE
+c====================================================================
+      INTEGER iunit, nbre
+      REAL x(nbre)
+c====================================================================
+      INTEGER i, l
+      INTEGER nbreok, ibaseok, icase
+      REAL xmax, xmin, errcod
+c====================================================================
+      INTEGER lbord
+      PARAMETER (lbord=255)
+      REAL conv(0:lbord)
+c====================================================================     
+      INTEGER ibase, maxcas, maxnbr, ifact1, ifact2, ifact3
+      PARAMETER (ibase=36, maxcas=3, maxnbr=100000)
+      PARAMETER(ifact1=ibase**1-1)
+      PARAMETER(ifact2=ibase**2-1)
+      PARAMETER(ifact3=ibase**3-1)
+      CHARACTER*1 base(ibase), fac(maxcas,maxnbr)
+      INTEGER inte(maxcas)
+      DATA (base(l),l=1,ibase)
+     .     /'0','1','2','3','4','5','6','7','8','9',
+     .      'A','B','C','D','E','F','G','H','I','J',
+     .      'K','L','M','N','O','P','Q','R','S','T',
+     .      'U','V','W','X','Y','Z'/
+c====================================================================
+      IF (nbre .GT. maxnbr) THEN
+      PRINT*, 'Verifier maxnbr dans from36 (trop petite)'
+      STOP
+      ENDIF
+      DO 10 i = 0, lbord
+   10 conv(i) = 1.0e+33
+c    34  c  10 conv(i) = 1.0e+49
+      DO 20 i = 1, ibase
+      l = ICHAR(base(i))
+   20 conv(l) = FLOAT(i-1)
+c====================================================================
+      READ (iunit,*) nbreok, ibaseok, icase
+        IF (nbre .NE. nbreok) THEN
+          PRINT*, 'Incoherence (Nombre elements)', nbreok, nbre
+          STOP
+        ENDIF
+        IF (ibase .NE. ibaseok) THEN
+          PRINT*, 'Incoherence (Nombre base)', ibaseok, ibase
+          STOP
+        ENDIF
+        IF (icase.NE.1 .AND. icase.NE.2 .AND. icase.NE.3) THEN
+          PRINT*, 'Verifier icase (1,2,3) dans le fichier a lire', 
+     .             icase
+          STOP
+        ENDIF
+c====================================================================
+      READ (iunit,*) xmin
+      READ (iunit,*) xmax
+        PRINT*,'Xmin et Xmax=', xmin, xmax
+c====================================================================
+      IF (xmin .EQ. xmax) THEN
+        READ(iunit,'(a)')
+        PRINT*, 'Ce champ est constant'
+        DO 30 i = 1, nbre
+   30   x(i) = xmin
+        GO TO 123
+      END IF
+c====================================================================
+      IF (icase .EQ. 1) THEN
+        errcod = (xmax-xmin) / FLOAT(ifact1)
+        PRINT*,'La precision du codage est entre + / - ', errcod
+        READ(iunit,91)((fac(l,i),l=1,icase),i=1,nbre)
+        DO 190 i = 1, nbre
+        x(i) = 0.0
+        DO 191 l = 1, icase
+        inte(l) = ICHAR( fac(l,i) )
+        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
+  191   CONTINUE
+        x(i) = xmin + x(i)/FLOAT(ifact1)*(xmax-xmin)
+  190   CONTINUE
+      ELSE IF (icase .EQ. 2) THEN
+        errcod = (xmax-xmin) / FLOAT(ifact2)
+        PRINT*,'La precision du codage est entre + / - ', errcod
+        READ(iunit,92)((fac(l,i),l=1,icase),i=1,nbre)
+        DO 290 i = 1, nbre
+        x(i) = 0.0
+        DO 291 l = 1, icase
+        inte(l) = ICHAR( fac(l,i) )
+        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
+  291   CONTINUE
+        x(i) = xmin + x(i)/float(ifact2)*(xmax-xmin)
+  290   CONTINUE
+      ELSE IF (icase .EQ. 3) THEN
+        errcod = (xmax-xmin) / FLOAT(ifact3)
+        PRINT*,'La precision du codage est entre + / - ', errcod
+        READ(iunit,93)((fac(l,i),l=1,icase),i=1,nbre)
+        DO 390 i = 1, nbre
+        x(i) = 0.0
+        DO 391 l = 1, icase
+        inte(l) = ICHAR( fac(l,i) )
+        x(i) = x(i) + conv ( inte(l) ) * FLOAT( ibase**(icase-l) )
+  391   CONTINUE
+        x(i) = xmin + x(i)/FLOAT(ifact3)*(xmax-xmin)
+  390   CONTINUE
+      ELSE
+        PRINT*, 'Verfier icase (1, 2 ou 3)'
+        STOP
+      ENDIF
+   91 FORMAT(120a1)
+   92 FORMAT(64(2a1))
+   93 FORMAT(40(3a1))
+c====================================================================
+  123 RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/gather.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/gather.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/gather.F	(revision 57)
@@ -0,0 +1,16 @@
+      SUBROUTINE GATHER(n,a,b,index)
+c
+      IMPLICIT NONE
+C
+      INTEGER n,index(n),i
+      REAL a(n),b(n)
+c
+      DO 100 i=1,n
+        a(i)=b(index(i))
+100   CONTINUE
+c
+      RETURN
+      END
+c
+c     voir aussi vec_gather(v,vindices,count,r)...p.11-14
+c  
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ilsum.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ilsum.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ilsum.F	(revision 57)
@@ -0,0 +1,19 @@
+      FUNCTION ilsum(n, logic, inc)
+c
+      IMPLICIT NONE
+c
+      integer ilsum
+      integer n, inc
+      logical logic((n-1)*inc+1)
+c
+      integer i, in
+c
+      ilsum = 0.
+      in = 1
+      do 10 i = 1, n
+         if (logic(in)) ilsum = ilsum + 1
+         in=in+inc
+10    continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ini36.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ini36.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ini36.F	(revision 57)
@@ -0,0 +1,46 @@
+      SUBROUTINE ini36
+Ccray IMPLICIT NONE
+      IMPLICIT NONE
+c====================================================================
+c-- cette routine fait l'initialisation pour le codage sur base 36
+c-- de la routine to36. on peut utiliser soit 1 soit 2 soit 3 cases
+      INTEGER i,j,k,l, ijk, jk
+c====================================================================
+      INTEGER ibase, ifact1, ifact2, ifact3
+      PARAMETER (ibase=36)
+      PARAMETER (ifact1 = ibase-1)
+      PARAMETER (ifact2 = ibase*ibase-1)
+      PARAMETER (ifact3 = ibase*ibase*ibase-1)
+c====================================================================
+      CHARACTER*1 word1(0:ifact1)
+      COMMON /elbat1/ word1
+      CHARACTER*2 word2(0:ifact2)
+      COMMON /elbat2/ word2
+      CHARACTER*3 word3(0:ifact3)
+      COMMON /elbat3/ word3
+c====================================================================
+      CHARACTER*1 base(ibase)
+      DATA (base(l),l=1,ibase)
+     .     /'0','1','2','3','4','5','6','7','8','9',
+     .      'A','B','C','D','E','F','G','H','I','J',
+     .      'K','L','M','N','O','P','Q','R','S','T',
+     .      'U','V','W','X','Y','Z'/
+c===================================================================
+      DO 30 i = 1, ibase
+      DO 30 j = 1, ibase
+      DO 30 k = 1, ibase
+      ijk = ( (i-1)*ibase + j-1 )*ibase + k-1
+      word3(ijk) = base(i)//base(j)//base(k)
+   30 CONTINUE
+      DO 20 j = 1, ibase
+      DO 20 k = 1, ibase
+      jk = (j-1)*ibase + k-1
+      word2(jk) = base(j)//base(k)
+   20 CONTINUE
+      DO 10 k = 1, ibase
+      word1(k-1) = base(k)
+   10 CONTINUE
+c===================================================================
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isamax.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isamax.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isamax.F	(revision 57)
@@ -0,0 +1,21 @@
+      function isamax(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      INTEGER n,i,incx,isamax,ix
+      real sx((n-1)*incx+1),sxmax,abssx
+c
+      ix=1
+      isamax=1
+      sxmax=ABS(sx(1))
+      do 10 i=1,n-1
+         ix=ix+incx
+         abssx=ABS(sx(ix))
+         if(abssx.gt.sxmax) then
+             sxmax=abssx
+             isamax=i+1
+         endif
+10    continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isitor.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isitor.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/isitor.F	(revision 57)
@@ -0,0 +1,64 @@
+
+      SUBROUTINE isitor(filename,writeornot,filenum, files)
+
+C--------------------------------------------------------------------
+C Subroutine qui determine si un fichier doit etre ecrit ou non
+C--------------------------------------------------------------------
+C     ARGUMENTS
+C     +++++++++
+C     filename: CHARACTER*20 
+C               nom du fichier dont on veut savoir si il doit etre ecrit
+C     writeornot: LOGICAL
+C                 Variable de sortie qui est vraie si le champ doit etre ecrit
+C     filenum: INTEGER
+C              nombre de fichier dans la list files
+C     files: CHARACTER*20 files(100)
+C            c'est la liste des fichier qui doivent etre ecrit et dans
+C            lequel on vas voir si filename y est.
+C
+
+
+      IMPLICIT NONE
+      CHARACTER*20 filename, checkname
+      CHARACTER*1 separator
+      LOGICAL writeornot, check
+      INTEGER iletter, ifile
+      INTEGER filenum
+      CHARACTER*20 files(100)
+
+      writeornot = .FALSE.
+      check = .FALSE.
+      separator = '/'
+
+      DO 6565 iletter = 20,1,-1
+
+        IF (filename(iletter:iletter) .EQ. separator) THEN
+
+          checkname = filename(iletter+1:20)
+    
+        ELSE
+        ENDIF
+ 6565 CONTINUE
+
+      IF (check) THEN
+        WRITE(*,*) 'ISITORNOT:: filename=',filename,
+     &             'checkname=',checkname
+      ENDIF
+
+      DO 6767 ifile = 1,filenum
+
+      IF (files(ifile) .EQ. checkname ) THEN
+       
+      writeornot = .TRUE. 
+
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'ISITORNOT:: writeornot=',writeornot
+      ENDIF
+
+ 6767 CONTINUE
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismax.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismax.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismax.F	(revision 57)
@@ -0,0 +1,20 @@
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismin.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismin.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ismin.F	(revision 57)
@@ -0,0 +1,20 @@
+      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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lmdstd.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lmdstd.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lmdstd.h	(revision 57)
@@ -0,0 +1,31 @@
+c=======================================================================
+c   INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
+
+      INTEGER bandmax
+      PARAMETER(bandmax=24)
+
+      COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
+     $                gentete,gdatedep,gdatefin
+        
+      CHARACTER*100 gtitre    !du champ
+      CHARACTER*20  gunites   !unites du champ
+      CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
+      CHARACTER*100 gfichier  !nom du fichier contenant le champ
+      CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
+      CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
+      CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
+      CHARACTER*20  glistfich !liste de champs a sortir
+
+      COMMON/lmdstdnu/ gminimum,gmaximum,
+     $                 gdeltajour(bandmax),gdeltapas(bandmax),
+     $                 gnbetats(bandmax),gnbfich
+
+      REAL    gminimum        ! \    min et max
+      REAL    gmaximum        ! /    du champ
+      INTEGER gnbfich         ! nombre de fichier a sortir
+c  pour les evolutions temporelles:
+      INTEGER gnbetats        ! nombre d'etats par bande
+      INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
+      REAL    gdeltajour      ! ecart en jour des sorties sur bandes
+
+c=======================================================================
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lnblnk.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lnblnk.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/lnblnk.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxm.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxm.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxm.F	(revision 57)
@@ -0,0 +1,34 @@
+       SUBROUTINE MXM(A,NAR,B,NAC,C,NBC)
+c
+c
+c    Multiplication of matrix A by matrix B ,and result in matrix C
+c
+c
+c      NAR : number of   rows  for matrix  A and  matrix  C
+c      NAC : number of columns for matrix  A and number of rows
+c                              for matrix  B
+c      NBC : number of columns for matrix  B and  matrix  C
+c
+c
+       IMPLICIT NONE
+c
+       INTEGER  NAR,NAC,NBC, I,J,K
+       REAL     A(NAR,NAC), B(NAC,NBC), C(NAR,NBC)
+c
+       DO 10 J = 1,NBC
+       DO 10 I = 1,NAR
+       C(I,J)=0.
+10     CONTINUE
+c
+       DO 50 J = 1,NBC
+       DO 40 I = 1,NAR
+
+       DO 20 K = 1,NAC
+       C(I,J)  = C(I,J) + A(I,K) * B(K,J)
+20     CONTINUE
+
+40     CONTINUE
+50     CONTINUE
+
+       RETURN
+       END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxv.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxv.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxv.F	(revision 57)
@@ -0,0 +1,20 @@
+      SUBROUTINE MXV(A,NRA,B,NCA,C)
+      IMPLICIT NONE
+
+      INTEGER NRA,NCA
+      REAL A(NRA,NCA), B(NCA), C(NRA)
+
+      INTEGER I,J
+
+c     initialize product
+      DO 100 I = 1, NRA
+         C(I) = 0.
+100   CONTINUE
+c     multiply matrix A and vector B
+      DO 220 J = 1, NCA
+         DO 210 I = 1, NRA
+            C(I) = C(I) + A(I,J)*B(J)
+210     CONTINUE
+220   CONTINUE
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxva.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxva.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mxva.F	(revision 57)
@@ -0,0 +1,25 @@
+      SUBROUTINE MXVA (SA,IAC,IAR,SB,IB,SC,IC,NRA,NCA)
+      IMPLICIT NONE
+
+      INTEGER IAC,IAR,IB,IC,NRA,NCA
+      REAL SA(*), SB(*), SC(*)
+
+      INTEGER I,J
+
+c     initialize product
+      DO 100 I = 1, NRA
+       SC( 1 + (I-1)*IC ) = 0.
+c      ( C(i) := 0. )
+100   CONTINUE
+c     multiply matrix from sa and vector from sb
+      DO 220 J = 1, NCA
+        DO 210 I = 1, NRA
+          SC( 1 + (I-1)*IC )
+     &      = SC( 1 + (I-1)*IC )
+     &        + SA( 1 + (I-1)*IAC + (J-1)*IAR )
+     &          * SB( 1 + (J-1)*IB )
+c         ( C(i) := C(i) + A(i,j)*B(j) )
+210      CONTINUE
+220   CONTINUE
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mywrite.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mywrite.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/mywrite.F	(revision 57)
@@ -0,0 +1,154 @@
+      SUBROUTINE mywrite(champ,icount,titre,unit,format,nom
+     &                  , entete, date0, date, deltpas, nbeta
+     &                  , deltajour, filenum, files)
+C----------------------------------------------------------
+C Subroutine qui ecrit les fichiers dans le format de transfert
+C vers le LMD.
+C format etabli par Zhao-Xin Li, Frederique Hourdin, Emmanuelle Cohen-Solal,
+C Jan Polcher . Il peut etre utilise pour sortire  des evolutions
+C temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
+C le character # place devant le format determine la fin de la 
+C description du champ et permet eventulellement de rajouter
+C des informations (avant le #).
+C le programme de lecture lit , dans la description, les variables
+C qu'il connait et saute apres jusquau #. A partir de la
+C il commence a lire le champ dans le format specifie.
+c------------------------------------------------------------
+C       ARGUMENTS
+C       +++++++++
+C champ: REAL (icount)
+C        champ contenant les valeurs et de longeur icount
+C icount: INTEGER
+C         nombre d'element dans le champ
+C titre: CHARACTER*100
+C        nom d'ecrivant le champ
+C unit: CHARACTER*20
+C       unites du champ
+C format: CHARACTER*20
+C         format dans le quel le champ doit etre ecrit.
+C         au choix:
+C                  - tous les format FORTRAN
+C                  - compactage de L.Li (zxliN) ou N peut valoir 1, 2 ou 3
+C nom: CHARACTER*20
+C      nom du fichier dans le quel le champ sera ecris, eventuellement
+C      avec directory (ex: evol/tsol)
+C entete: CHARACTER*100
+C         une entete du fichier pouvant par exemple decrire le run
+C date0: CHARACTER*8
+C        date de depart de la moyenne ou de l'evolution temporelle que contient
+C        le fichier
+C date : CHARACTER*8
+C        date de fin de la moyenne ou de l'evolution temporelle que contient
+C        le fichier
+C deltpas: INTEGER (bandmax)
+C          decript le nombre de pas de temps entre deux sorties pour chamque
+C          bande (necesaire pour les evolutions temporelles)
+C nbeta: INTEGER (bandmax)
+C        donne le nombre d'etas par bande (necesaire pour les evolutions 
+C        temporelles)
+C deltajour: REAL (bandmax)
+C             l'ecart en jours des iscriptions sur chaque bande (necesaire 
+C             pour les evolutions temporelles)
+C filenum: INTEGER
+C          nombre d'elements dans la liste files des champs desires
+C          si filenum = 0 alors tous les champs sont sortis  
+C files: CHARACTER*20 (100)
+C        list des champ que l'on desire sortire
+C
+C        PARAMETER
+C        +++++++++
+C bandmax: INTEGER
+C          le nombre maximale que peut traiter le programme
+C
+
+
+      IMPLICIT NONE
+
+      INTEGER bandmax
+      PARAMETER (bandmax = 24)
+      INTEGER icount,i,imin,imax
+      REAL champ(icount)
+      CHARACTER*100 titre, entete
+      CHARACTER unit*20,nom*80
+      CHARACTER*20 format
+      CHARACTER*8 date0, date
+      INTEGER deltpas(bandmax), nbeta(bandmax)
+      REAL deltajour(bandmax)
+      LOGICAL check, writeornot
+      INTEGER lnblnk,ismin,ismax
+      INTEGER filenum
+      CHARACTER*20 files(100)
+      EXTERNAL lnblnk,ismin,ismax, isitor, to36
+
+      check = .FALSE.
+
+      IF (filenum .EQ. 0) THEN
+        writeornot = .TRUE.
+      ELSE
+        CALL isitor(nom,writeornot,filenum, files)
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'MYWRITE:: writeornot=',writeornot
+      ENDIF
+
+      IF (writeornot) THEN
+      imin = ismin(icount,champ,1)
+      imax = ismax(icount,champ,1)
+      IF (check) THEN
+        WRITE(*,*) entete(1:lnblnk(entete))
+        WRITE(*,*) titre(1:lnblnk(titre))
+        WRITE(*,*) date0
+        WRITE(*,*) date
+        WRITE(*,*) unit(1:lnblnk(unit))
+        WRITE(*,*) deltpas, nbeta
+        WRITE(*,*) deltajour
+        WRITE(*,*) champ(imin),champ(imax)
+        WRITE(*,*) format(1:lnblnk(format))
+        WRITE(*,*) icount
+      ENDIF
+      WRITE(*,*) titre(1:lnblnk(titre)),'min,max:',
+     &           champ(imin),champ(imax),'  ',unit(1:lnblnk(unit))
+      
+      OPEN (unit=55, file=nom(1:lnblnk(nom)))
+      WRITE(55,'(a)') entete(1:lnblnk(entete))
+      WRITE(55,'(a)') titre(1:lnblnk(titre))
+      WRITE(55,'(a)') date0
+      WRITE(55,'(a)') date
+      WRITE(55,'(a)') unit(1:lnblnk(unit))
+      WRITE(55,*) deltpas, nbeta
+      WRITE(55,*) deltajour
+      WRITE(55,*) champ(imin),champ(imax)
+      WRITE(55,'(a)') '#'//format(1:lnblnk(format))
+      WRITE(55,*) icount
+
+      IF (check) THEN
+        WRITE(*,'('//format(1:lnblnk(format))//')') champ(1)
+      ENDIF
+
+      IF (format(1:lnblnk(format)) .EQ. 'zxli1') THEN
+        CALL to36 (champ,icount,champ(imin),champ(imax),55, 1)
+      ELSE 
+        IF (format(1:lnblnk(format)) .EQ. 'zxli2') THEN
+          CALL to36 (champ, icount,champ(imin), champ(imax),55, 2)
+        ELSE
+          IF (format(1:lnblnk(format)) .EQ. 'zxli3') THEN
+            CALL to36 (champ,icount,champ(imin),champ(imax),55, 3)
+          ELSE
+            DO 2233 i=1,icount
+              WRITE(55,'('//format(1:lnblnk(format))//')') 
+     &             champ(i)
+ 2233       CONTINUE
+          ENDIF
+        ENDIF
+      ENDIF
+
+      CLOSE (unit=55)
+
+      ELSE
+        WRITE(*,*) 'FILE    ',nom,'WAS NOT WRITEN'
+      ENDIF
+      
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readcoord.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readcoord.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readcoord.F	(revision 57)
@@ -0,0 +1,123 @@
+      SUBROUTINE readcoord(imx,jmx,lmx,imax,jmax,lmax,x,y,z,pathcoor)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs Jan Polcher, Frederic Hourdin
+c   -------
+c
+c   Objet   Lecture du fichier contenant des coordonnees x,y et z.
+c   -----
+c
+c   Inteface
+c   --------
+c
+c   Arguments:
+c   ----------
+c
+c   input
+c   -----
+c      imx   \
+c      jmx          dimensions des coordonnees
+c      lmx   /
+c      pathcoor     path absolu pour le fichier des coordonnees
+c                   CHARACTER*80
+c
+c   ouput
+c   -----
+c      imax         nombre de coordonnees x effectives
+c      jmax         nombre de coordonnees y effectives
+c      lmax         nombre de coordonnees z effectives
+c      x(imx)
+c      y(jmx)
+c      z(lmx)
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+c   arguments:
+c   ----------
+
+      INTEGER imx,jmx,lmx
+      INTEGER imax,jmax,lmax
+
+      REAL x(imx),y(jmx),z(lmx)
+
+      CHARACTER*80 pathcoor
+
+c   local
+c   -----
+
+      INTEGER i,j,l
+
+      CHARACTER*100 filecoor,messerr
+
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      messerr=' '
+      filecoor='coord.def'
+
+c-----------------------------------------------------------------------
+
+100   IF(pathcoor(1:1).EQ.'/') THEN
+         filecoor= pathcoor(:lnblnk(pathcoor))//filecoor
+      ENDIF
+      OPEN (99,file=filecoor,err=200,status='old',form='formatted')
+      GO TO 300
+
+200   WRITE(*,*) messerr
+      WRITE(*,*) 'entrer le nom du fichier des coordonnees puis RETURN'
+      WRITE(*,*) 'ou seulement RETURN pour arreter le programme'
+      READ(*,'(a)') filecoor
+      IF(filecoor(1:1).EQ.' ') STOP
+      CLOSE (99)
+      GOTO 100
+
+300   CONTINUE
+
+      READ(99,*,err=9999) imax
+      IF(imax.GT.imx) THEN
+        WRITE(6,1000) 'x',imx,imax
+        STOP
+      ENDIF
+      READ(99,*) (x(i),i=1,imax)
+
+      READ(99,*,err=9999) jmax
+      IF(jmax.GT.jmx) THEN
+        WRITE(6,1000) 'y',jmx,jmax
+        STOP
+      ENDIF
+      READ(99,*,err=9999) (y(j),j=1,jmax)
+
+      READ(99,*,err=9999) lmax
+      IF(lmax.GT.lmx) THEN
+        WRITE(6,1000) 'z',lmx,lmax
+        STOP
+      ENDIF
+      READ(99,*) (z(l),l=1,lmax)
+
+      CLOSE(99)
+
+c-----------------------------------------------------------------------
+
+      RETURN
+
+9999  PRINT*,'Le fichier ',filecoor,' que vous lisez est mal structure'
+      PRINT*,'Il doit contenir :'
+      PRINT*,'  le nombre de points en x suivi des valeurs de x'
+      PRINT*,'  puis la meme chose pour y et z'
+      STOP
+
+1000  FORMAT(/,
+     $ 'Probleme avec le fichier de coordonnees',/,
+     $ 'Le tableau contenant ',a3,' est dimenssionne a ',i4,/,
+     $ 'et le fichier de coordonnees contient ',i4,' valeurs.')
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readstd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readstd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/readstd.F	(revision 57)
@@ -0,0 +1,286 @@
+      SUBROUTINE readstd(imx,champ,imax)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteurs:   Jan Polcher, Frederic Hourdin  20/04/91
+c   --------
+c
+c   Objet:
+c   ------
+c
+c Subroutine qui lit les fichiers dans le format lmdstd
+c format etabli par :
+c  Jan Polcher,Zhao-Xin Li, Frederic Hourdin, Emmanuelle Cohen-Solal,
+c Il peut etre utilise pour sortire  des evolutions
+c temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
+c le character # place devant le format determine la fin de la 
+c description du champ et permet eventulellement de rajouter
+c des informations (avant le #).
+c le programme de lecture lit , dans la description, les variables
+c qu'il connait et saute apres jusquau #. A partir de la
+c il commence a lire le champ dans le format specifie.
+c
+c-----------------------------------------------------------------------
+c
+c   Interface:
+c   ----------
+c
+c   ARGUMENTS
+c   ---------
+c
+c imx  : INTEGER
+c        taille du tableau contenant le champ
+c champ: REAL (imx)
+c        champ contenant les valeurs et de longeur icount
+c imax : INTEGER
+c        nombre d'element dans le champ
+c
+c   COMMON:
+c   -------
+c
+c=======================================================================
+c  INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
+c
+c     INTEGER bandmax
+c     PARAMETER(bandmax=24)
+c
+c     COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
+c    $                gentete,gdatedep,gdatefin
+c       
+c     CHARACTER*100 gtitre    !du champ
+c     CHARACTER*20  gunites   !unites du champ
+c     CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
+c     CHARACTER*100 gfichier  !nom du fichier contenant le champ
+c     CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
+c     CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
+c     CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
+c     CHARACTER*20  glistfich !liste de champs a sortir
+c
+c     COMMON/lmdstdnu/ gminimum,gmaximum,
+c    $                 gdeltajour(bandmax),gdeltapas(bandmax),
+c    $                 gnbetats(bandmax),gnbfich
+c
+c     REAL    gminimum        ! \    min et max
+c     REAL    gmaximum        ! /    du champ
+c     INTEGER gnbfich         ! nombre de fichier a sortir
+c pour les evolutions temporelles:
+c     INTEGER gnbetats        ! nombre d'etats par bande
+c     INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
+c     REAL    gdeltajour      ! ecart en jour des sorties sur bandes
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "lmdstd.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER imx,imax
+      REAL champ(imx)
+
+c   Local:
+c   ------
+
+      INTEGER i
+
+      CHARACTER*200 test(20)
+      CHARACTER*200 helptest(20)
+      CHARACTER*200 help
+      INTEGER reccount
+
+      LOGICAL check,continue
+
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      check = .FALSE.
+      DO 9876 i=1,20
+        helptest(i) = '        '
+ 9876 CONTINUE
+
+
+c-----------------------------------------------------------------------
+c   lecture le l'entete:
+c   --------------------
+
+ 2222 OPEN (unit=10,file=gfichier(1:lnblnk(gfichier)), form='formatted',
+     &      ERR = 9999, status='old')
+      GOTO 1111
+
+ 9999 WRITE(*,*) 'Je ne peut pas lire le fichier: ',
+     & gfichier(1:lnblnk(gfichier))
+      CLOSE(10)
+      WRITE(*,*) 'Entrez S.V.P. un autre nom de fichier (path absolu) '
+      WRITE(*,*) 'ou RETURN pour stopper lexecution'
+      READ (*,'(a)') gfichier
+      IF(lnblnk(gfichier).EQ.0) STOP
+      GOTO 2222
+
+ 1111 continue = .TRUE.
+      DO 2345 i=1,20
+        IF (continue) THEN
+          READ (10,'(a200)') test(i)
+          IF ( test(i)(1:1) .EQ. '#' .OR. test(i)(1:1) .EQ. 'f10' ) THEN
+            continue = .FALSE.
+            reccount = i
+          ENDIF
+        ENDIF
+ 2345 CONTINUE
+
+      DO 1223 i=1,reccount-1
+        helptest(i) = test(i)
+ 1223 CONTINUE
+      helptest(20) = test(reccount)
+
+
+      IF (check) THEN
+        WRITE(*,*) 'gentete'
+      ENDIF
+      IF ( helptest(1) .NE. ' ' ) THEN
+        read (helptest(1),'(a100)') gentete
+      ELSE
+c       WRITE(*,*) 'la description du run'
+c       READ (*,'(a100)') gentete
+        gentete = '    '
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'titre'
+      ENDIF
+      IF ( helptest(2) .NE. ' ' ) THEN
+        read (helptest(2),'(a100)') gtitre
+      ELSE
+c       WRITE(*,*) 'le titre du dessin'
+c       READ (*,'(a100)') gtitre 
+        gtitre = '    '
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'datefins'
+      ENDIF
+      IF ( helptest(3) .NE. ' ' ) THEN
+        read (helptest(3),'(a8)') gdatedep 
+        read (helptest(4),'(a8)') gdatefin
+      ELSE
+c       WRITE(*,*)
+c    &  'datefin du debut de la moyenne (ou le mois tout simplement)'
+c       READ (*,'(a8)') gdatedep 
+c       WRITE(*,*) 'et celle de la fin (ou rien du tout)'
+c       READ (*,'(a8)') gdatefin 
+        gdatedep = '       '
+        gdatefin = '       '
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'unitees'
+      ENDIF
+      IF ( helptest(5) .NE. ' ' ) THEN
+        read (helptest(5),'(a20)') gunites
+      ELSE
+c       WRITE(*,*) 'les unitees du champ'
+c       READ (*,'(a20)') gunites
+        gunites = '                    '
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'deltapas et nbetats'
+      ENDIF
+      IF ( helptest(6) .NE. ' ' ) THEN
+c       READ (helptest(6),*,ERR=1212) 
+c    .       (gdeltapas(i),i=1,bandmax),(gnbetats(i),i=1,bandmax)
+        GOTO 1213
+
+ 1212   help =helptest(6)(1:lnblnk(helptest(6)))//
+     .        helptest(7)(1:lnblnk(helptest(7)))
+        helptest(6) = help
+        IF (check) THEN
+          WRITE(*,*) 'Problems while reading', help
+        ENDIF
+        DO  1214 i=7,reccount
+          helptest(i) = helptest(i+1)
+ 1214   CONTINUE
+c       READ (helptest(6),*,ERR=1212) 
+c    .       (gdeltapas(i),i=1,bandmax),(gnbetats(i),i=1,bandmax)
+
+ 1213   CONTINUE
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'deltajour'
+      ENDIF
+      IF ( helptest(7) .NE. ' ' ) THEN
+c       READ (helptest(7),*,ERR=1312) (gdeltajour(i),i=1,bandmax)
+        GOTO 1313
+
+ 1312   help =helptest(7)(1:lnblnk(helptest(7)))//
+     .        helptest(8)(1:lnblnk(helptest(8)))
+        helptest(7) = help
+        IF (check) THEN
+          WRITE(*,*) 'Problems while reading', help
+        ENDIF
+        DO  1314 i=8,reccount
+          helptest(i) = helptest(i+1)
+ 1314   CONTINUE
+c       READ (helptest(7),*,ERR=1312) (gdeltajour(i),i=1,bandmax)
+
+ 1313   CONTINUE
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'min et max'
+      ENDIF
+      IF ( helptest(8) .NE. ' ' ) THEN
+c       READ (helptest(8),*)     gminimum,gmaximum
+      ENDIF
+
+      gformat = helptest(20)(2:20)
+
+      IF (check) THEN
+        WRITE(*,*) gentete
+        WRITE(*,*) gtitre
+        WRITE(*,*) gdatedep
+        WRITE(*,*) gdatefin 
+        WRITE(*,*) gdeltapas,gnbetats
+        WRITE(*,*) gdeltajour
+        WRITE(*,*) gminimum,gmaximum
+        WRITE(*,*) gformat
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   lecture du champ proprement dit:
+c   --------------------------------
+
+      READ (10,*)     imax
+   
+      IF(imax.GT.imx) THEN
+         WRITE(*,*) 'Vous essayez de lire un champ dont la taille est'
+         WRITE(*,*) 'superieure a la taille maximum autorisee'
+         WRITE(*,*) 'c est a dire a la dimension du champ utilise'
+         WRITE(*,*) 'pour lappel a la procedure writestd.'
+         STOP
+      ENDIF
+
+      IF (gformat(1:4) .EQ. 'zxli') THEN
+        CALL from36 (champ,imax,10)
+      ELSE 
+         IF (lnblnk(gformat).LE.1.OR.lnblnk(gformat).GE.20) THEN
+            READ(10,*) (champ (i),i=1,imax)
+         ELSE
+            READ(10,'('//gformat(1:lnblnk(gformat))//')')
+     $      (champ (i),i=1,imax)
+         ENDIF
+      ENDIF
+
+      CLOSE (unit=10)
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scatter.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scatter.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scatter.F	(revision 57)
@@ -0,0 +1,21 @@
+       subroutine scatter(n,a,index,b)
+C
+       implicit none
+       integer N,INDEX(n),I
+       real A(n),B(n)
+c
+c
+       DO 100 I=1,N
+          A(INDEX(I))=B(I)
+100    CONTINUE
+c
+       return
+       end 
+c
+c
+c      peut etre vec_scatter(v,rindices,count,r) en f77hp
+c      equivalent code:
+c      do 99 i=1,count
+c99    r(rindices(i))=v(i)
+c      voir p. 11-13
+c
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopy.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopy.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopy.F	(revision 57)
@@ -0,0 +1,17 @@
+      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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopyi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopyi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/scopyi.F	(revision 57)
@@ -0,0 +1,17 @@
+      subroutine scopyi(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      integer sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+      sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/sdot.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/sdot.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/sdot.F	(revision 57)
@@ -0,0 +1,21 @@
+      FUNCTION sdot (n, x,incx, y,incy)
+      IMPLICIT NONE
+c
+      integer n, incx, incy
+      real sdot
+      real x((n-1)*incx+1), y((n-1)*incy+1)
+c
+      integer i, ix, iy
+c
+      sdot = 0.0
+      ix = 1
+      iy = 1
+c
+      do 10 i = 1, n
+         sdot = sdot + x(ix) * y(iy)
+         ix = ix + incx
+         iy = iy + incy
+   10 continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ssum.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ssum.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/ssum.F	(revision 57)
@@ -0,0 +1,16 @@
+      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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/to36.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/to36.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/to36.F	(revision 57)
@@ -0,0 +1,84 @@
+      SUBROUTINE to36(x,nbre,xmin,xmax,iunit,icase)
+Ccray IMPLICIT NONE
+      IMPLICIT NONE
+c=======================================================================
+c-- x    : le champ a compacter
+c-- nbre : la taille du champ x
+c-- iunit: numero logique du fichier sortie
+c-- icase: nombre de cases a utiliser (qui determine la precision)
+      INTEGER iunit, nbre, icase
+      REAL x(nbre) 
+c=======================================================================
+      INTEGER ibase, maxnbr, ifact1, ifact2, ifact3
+      PARAMETER (ibase=36, maxnbr=100000)
+      PARAMETER (ifact1 = ibase**1-1)
+      PARAMETER (ifact2 = ibase**2-1)
+      PARAMETER (ifact3 = ibase**3-1)
+c=======================================================================
+      CHARACTER*1 word1(0:ifact1)
+      COMMON /elbat1/ word1
+      CHARACTER*1 chax1(maxnbr)
+c======================================================================
+      CHARACTER*2 word2(0:ifact2)
+      COMMON /elbat2/ word2
+      CHARACTER*2 chax2(maxnbr)
+c======================================================================
+      CHARACTER*3 word3(0:ifact3)
+      COMMON /elbat3/ word3
+      CHARACTER*3 chax3(maxnbr)
+c=====================================================================
+      INTEGER i, inte
+      REAL xmin, xmax
+      EXTERNAL ini36
+c=====================================================================
+c
+c--- initialisation pour le codage
+c la routine ini36 est appelee une seule fois
+c     IF (word1(36) .NE. 'Z' ) THEN
+        CALL ini36
+c     ENDIF
+
+      IF (nbre .GT. maxnbr) THEN
+        PRINT*, 'Nombre elements trop grand', nbre, maxnbr
+        STOP
+      ENDIF
+c
+      WRITE(iunit,*) nbre, ibase, icase, '  (nbre,ibase,icase)'
+      WRITE(iunit,*) xmin
+      WRITE(iunit,*) xmax
+c
+      IF(xmin .EQ. xmax)THEN
+      WRITE(iunit,'(a)')'Ce champ est constant'
+      GO TO 999
+      ENDIF 
+c
+      IF (icase .EQ. 1) THEN
+        DO 10 i = 1, nbre
+          inte = NINT( FLOAT(ifact1)/(xmax-xmin) * (x(i)-xmin) )
+          chax1(i) = word1(inte)
+   10   CONTINUE
+        WRITE(iunit,91) (chax1(i),i=1,nbre)
+      ELSE IF (icase .EQ. 2) THEN
+        DO 20 i = 1, nbre
+          inte = NINT( FLOAT(ifact2)/(xmax-xmin) * (x(i)-xmin) )
+          chax2(i) = word2(inte)
+   20   CONTINUE
+        WRITE(iunit,92) (chax2(i),i=1,nbre)
+      ELSE IF (icase.eq.3) THEN
+        DO 30 i = 1, nbre
+          inte = NINT( FLOAT(ifact3)/(xmax-xmin) * (x(i)-xmin) )
+          chax3(i) = word3(inte)
+   30   CONTINUE
+        WRITE(iunit,93) (chax3(i),i=1,nbre)
+      ELSE
+        PRINT*, 'Verfier icase (1,2,3) dans les arguments de to36'
+        STOP
+      ENDIF
+c
+   91 FORMAT(120a1)
+   92 FORMAT(64a2)
+   93 FORMAT(40a3)
+c
+  999 RETURN
+      END 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/wheneq.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/wheneq.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/wheneq.F	(revision 57)
@@ -0,0 +1,23 @@
+      SUBROUTINE wheneq(n,x,incx,target,index,nn)
+      IMPLICIT NONE
+c
+      integer n, incx, nn
+      integer index(n)
+c
+      integer target, x((n-1)*incx+1)
+cccccc      real target, x((n-1)*incx+1)
+c
+      integer i, ix
+c
+      ix = 1
+      nn = 0
+      do 10 i = 1, n
+         if (x(ix).EQ.target) then
+            index(i) = ix
+            nn = nn + 1
+         endif
+         ix = ix + incx
+   10 continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/writestd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/writestd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/bibio/writestd.F	(revision 57)
@@ -0,0 +1,200 @@
+      SUBROUTINE writestd(champ,icount)
+
+c=======================================================================
+c
+c   Auteurs:   Jan Polcher, Frederic Hourdin
+c   --------
+c
+c   Objet:
+c   ------
+c
+c Subroutine qui ecrit les fichiers dans le format de transfert
+c vers le LMD.
+c format etabli par :
+c   Zhao-Xin Li, Frederic Hourdin, Emmanuelle Cohen-Solal,
+c   Jan Polcher .
+c Il peut etre utilise pour sortire  des evolutions
+c temporelles, des champs 2D (iim,jjm ou jjm,llm) ou des champs 3D.
+c le character # place devant le format determine la fin de la 
+c description du champ et permet eventulellement de rajouter
+c des informations (avant le #).
+c le programme de lecture lit , dans la description, les variables
+c qu'il connait et saute apres jusquau #. A partir de la
+c il commence a lire le champ dans le format specifie.
+c
+c-----------------------------------------------------------------------
+c
+c   Interface:
+c   ----------
+c
+c   ARGUMENTS
+c   ---------
+c
+c champ: REAL (icount)
+c        champ contenant les valeurs et de longeur icount
+c icount: INTEGER
+c        nombre d'element dans le champ
+c
+c   COMMON:
+c   -------
+c
+c=======================================================================
+c  INCLUDE '/usr/local/lmdgraph/libio/lmdstd.h'
+c
+c     INTEGER bandmax
+c     PARAMETER(bandmax=24)
+c
+c     COMMON/lmdstdch/gtitre,gunites,gformat,gfichier,glistfich(100),
+c    $                gentete,gdatedep,gdatefin
+c       
+c     CHARACTER*100 gtitre    !du champ
+c     CHARACTER*20  gunites   !unites du champ
+c     CHARACTER*20  gformat   !formats FORTRAN ou zxliN (N=1,2,3) ou ''
+c     CHARACTER*100 gfichier  !nom du fichier contenant le champ
+c     CHARACTER*100 gentete   !nom generique (exemple desript. du RUN)
+c     CHARACTER*8   gdatedep  !date de depart de la moy. ou evol. temp.
+c     CHARACTER*8   gdatefin  !date de fin '' si une seule datefin
+c     CHARACTER*20  glistfich !liste de champs a sortir
+c
+c     COMMON/lmdstdnu/ gminimum,gmaximum,
+c    $                 gdeltajour(bandmax),gdeltapas(bandmax),
+c    $                 gnbetats(bandmax),gnbfich
+c
+c     REAL    gminimum        ! \    min et max
+c     REAL    gmaximum        ! /    du champ
+c     INTEGER gnbfich         ! nombre de fichier a sortir
+c pour les evolutions temporelles:
+c     INTEGER gnbetats        ! nombre d'etats par bande
+c     INTEGER gdeltapas       ! nombre de pas de temps entre 2 sorties
+c     REAL    gdeltajour      ! ecart en jour des sorties sur bandes
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+      IMPLICIT NONE
+#include "lmdstd.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER icount
+      REAL champ(icount)
+
+c   Local:
+c   ------
+
+      INTEGER i,imin,imax
+      LOGICAL check, writeornot
+      INTEGER lnblnk,ismin,ismax
+      EXTERNAL lnblnk,ismin,ismax, isitor, to36
+
+      INTEGER indexfil
+      COMMON/indexfil/indexfil
+
+c-----------------------------------------------------------------------
+c   verification que le champ est dans la liste predefinie:
+c   -------------------------------------------------------
+
+      check = .FALSE.
+
+      IF (gnbfich .EQ. 0) THEN
+        writeornot = .TRUE.
+      ELSE
+        CALL isitor(gfichier,writeornot,gnbfich, glistfich)
+      ENDIF
+
+      IF (check) THEN
+        WRITE(*,*) 'MYWRITE:: writeornot=',writeornot
+      ENDIF
+
+c-----------------------------------------------------------------------
+      IF (writeornot) THEN
+c-----------------------------------------------------------------------
+
+      imin = ismin(icount,champ,1)
+      imax = ismax(icount,champ,1)
+      IF (check) THEN
+        WRITE(*,*) gentete(1:lnblnk(gentete))
+        WRITE(*,*) gtitre(1:lnblnk(gtitre))
+        WRITE(*,*) gdatedep
+        WRITE(*,*) gdatefin
+        WRITE(*,*) gunites(1:lnblnk(gunites))
+        WRITE(*,*) gdeltapas, gnbetats
+        WRITE(*,*) gdeltajour
+        WRITE(*,*) champ(imin),champ(imax)
+        WRITE(*,*) gformat(1:lnblnk(gformat))
+        WRITE(*,*) icount
+      ENDIF
+      WRITE(*,*) gtitre(1:lnblnk(gtitre)),'min,max:',
+     &  champ(imin),champ(imax),'  ',gunites(1:lnblnk(gunites))
+      
+c-----------------------------------------------------------------------
+c   creation eventuelle d'un nom pour le fichier d'ecriture du champ:
+c   -----------------------------------------------------------------
+
+      IF(lnblnk(gfichier).LT.1.OR.lnblnk(gfichier).GE.100) THEN
+         gfichier(1:5)='champ'
+         IF(indexfil.LT.1) indexfil=49
+         gfichier(6:6)=char(indexfil)
+	 indexfil=indexfil+1
+	 PRINT*,'nom du fichier  ',gfichier
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   ecriture sur le fichier de sorties:
+c   -----------------------------------
+
+      OPEN (unit=55, file=gfichier(1:lnblnk(gfichier)))
+      WRITE(55,'(a)') gentete(1:lnblnk(gentete))
+      WRITE(55,'(a)') gtitre(1:lnblnk(gtitre))
+      WRITE(55,'(a)') gdatedep
+      WRITE(55,'(a)') gdatefin
+      WRITE(55,'(a)') gunites(1:lnblnk(gunites))
+      WRITE(55,*) gdeltapas, gnbetats
+      WRITE(55,*) gdeltajour
+      WRITE(55,*) champ(imin),champ(imax)
+      WRITE(55,'(a)') '#'//gformat(1:lnblnk(gformat))
+      WRITE(55,*) icount
+
+      IF (check) THEN
+        WRITE(*,'('//gformat(1:lnblnk(gformat))//')') champ(1)
+      ENDIF
+
+      IF (lnblnk(gformat).LE.1.OR.lnblnk(gformat).GE.20) THEN
+         DO 2230 i=1,icount
+            WRITE(55,*) champ(i)
+2230     CONTINUE
+      ELSE
+         IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli1') THEN
+            CALL to36 (champ,icount,champ(imin),champ(imax),55, 1)
+         ELSE 
+            IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli2') THEN
+               CALL to36(champ,icount,champ(imin),champ(imax),55,2)
+            ELSE
+               IF (gformat(1:lnblnk(gformat)) .EQ. 'zxli3') THEN
+                  CALL to36(champ,icount,champ(imin),champ(imax),55,3)
+               ELSE
+                  WRITE(55,'('//gformat(1:lnblnk(gformat))//')') 
+     &            (champ(i),i=1,icount)
+               ENDIF
+            ENDIF
+         ENDIF
+      ENDIF
+
+      CLOSE (unit=55)
+
+      gfichier=' '
+
+c-----------------------------------------------------------------------
+c   si on ecrit pas le champ (writeornot.EQ..f.):
+c   ---------------------------------------------
+
+      ELSE
+        WRITE(*,*) 'FILE    ',gfichier,'WAS NOT WRITEN'
+      ENDIF
+      
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/LISEZMOI
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/LISEZMOI	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/LISEZMOI	(revision 57)
@@ -0,0 +1,136 @@
+
+Version abbrégé spécial Mars
+
+ ..  Version  du 28/12/1998  , avec  nouveau fxyhyper appele par inigeom ...
+ **************************************************************************
+
+ 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    . 
+
+            
+   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
+
+   
+
+ 2) Une des variables prognostiques de LMDZ.3  est   teta  , temperature 
+     potentielle  :    
+
+                 teta (ij,l) = temperature(ij,l) * cp/ pk(ij,l)
+ 
+    
+ 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 = 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 .
+
+
+ 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  .
+  
+
+
+
+ ****************************************************************************
+
+ 
+ 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
+
+     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  diagfi
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/abort_gcm.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/abort_gcm.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/abort_gcm.F	(revision 57)
@@ -0,0 +1,24 @@
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+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'
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addfi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addfi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addfi.F	(revision 57)
@@ -0,0 +1,182 @@
+      SUBROUTINE addfi(nq, pdt, leapf, forward,
+     S          pucov, pvcov, pteta, pq   , pps , pmasse ,
+     S          pdufi, pdvfi, pdhfi,pdqfi, pdpfi  )
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c    Addition of the physical tendencies
+c    Modif special Mars :
+c       - no special treatment of iq = 1, 2, FF 2003
+c       - recompute mass after incrementation of ps (EM,FF 2008)
+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      pmasse(ip1jmp1,llm)    ! mass
+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"
+#include "comvert.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)
+
+      real pmasse(ip1jmp1,llm)
+c
+      LOGICAL leapf,forward
+c
+c
+c    Local variables :
+c    -----------------
+c
+      REAL xpn(iim),xps(iim),tpn,tps
+      INTEGER j,k,iq,ij
+      REAL qtestw, qtestt
+      PARAMETER ( qtestw = 1.0e-15 )
+      PARAMETER ( qtestt = 1.0e-30 )
+
+      real p(ip1jmp1,llm) ! pressure
+
+      REAL SSUM
+      EXTERNAL SSUM
+c
+c-----------------------------------------------------------------------
+! increment potential temperature
+      DO k = 1,llm
+         DO j = 1,ip1jmp1
+            pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+      DO  k    = 1, llm
+       DO  ij   = 1, iim
+         xpn(ij) = aire(   ij   ) * pteta(  ij    ,k)
+         xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k)
+       ENDDO
+       tpn      = SSUM(iim,xpn,1)/ apoln
+       tps      = SSUM(iim,xps,1)/ apols
+
+       DO ij   = 1, iip1
+         pteta(   ij   ,k)  = tpn
+         pteta(ij+ip1jm,k)  = tps
+       ENDDO
+      ENDDO
+c
+
+! increment covariant zonal wind
+      DO k = 1,llm
+         DO j = iip2,ip1jm
+            pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+! increment covariant meridional wind
+      DO k = 1,llm
+         DO j = 1,ip1jm
+            pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt
+         ENDDO
+      ENDDO
+
+c
+! increment surface pressure
+      DO j = 1,ip1jmp1
+         pps(j) = pps(j) + pdpfi(j) * pdt
+      ENDDO
+
+c     DO iq = 1, 2 ! special Mars: no special treatment for water
+c        DO k = 1,llm
+c           DO j = 1,ip1jmp1
+c              pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt
+c              pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw )
+c           ENDDO
+c        ENDDO
+c     ENDDO
+
+      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), qtestt )
+            ENDDO
+         ENDDO
+      ENDDO
+                                       
+
+       DO  ij   = 1, iim
+         xpn(ij) = aire(   ij   ) * pps(  ij     )
+         xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm )
+       ENDDO
+       tpn      = SSUM(iim,xpn,1)/apoln
+       tps      = SSUM(iim,xps,1)/apols
+
+       DO ij   = 1, iip1
+         pps (   ij     )  = tpn
+         pps ( ij+ip1jm )  = tps
+       ENDDO
+
+! recompute mass: (to be synchronous with update of ps)
+      CALL pression ( ip1jmp1, ap, bp, pps, p )
+      CALL massdair (     p  , pmasse         )
+ 
+
+
+       DO iq = 1, nq
+         DO  k    = 1, llm
+           DO  ij   = 1, iim
+             xpn(ij) = aire(   ij   ) * pq(  ij    ,k,iq)
+             xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq)
+           ENDDO
+           tpn      = SSUM(iim,xpn,1)/apoln
+           tps      = SSUM(iim,xps,1)/apols
+
+           DO ij   = 1, iip1
+             pq (   ij   ,k,iq)  = tpn
+             pq (ij+ip1jm,k,iq)  = tps
+           ENDDO
+         ENDDO
+       ENDDO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addit.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addit.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/addit.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/adv_h2o.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/adv_h2o.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/adv_h2o.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/advect.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/advect.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/advect.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont_qsat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont_qsat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/amont_qsat.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/angtot.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/angtot.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/angtot.h	(revision 57)
@@ -0,0 +1,8 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'angtot.h
+
+      COMMON/angtot/dangdyn,dangm1,dangdis,dangdif
+
+      REAL dangdyn,dangm1,dangdis,dangdif
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_mcdstats.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_mcdstats.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_mcdstats.F	(revision 57)
@@ -0,0 +1,1375 @@
+      PROGRAM anldiag_nc
+      IMPLICIT NONE
+c======================================================================
+c
+c
+c Program designed to read output files from the MARS gcm
+c or the Mars Climate database.
+c
+c    Francois Forget 1999
+c    Version used by monica to interpolate in zaeroid and p coordinate
+
+c
+c=======================================================================
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "netcdf.inc"
+
+      INTEGER itau,nbpas,nbpasmx, coor,sor,varoutsize
+      integer varspecsize
+      integer varout(6),varspec(nqmx)
+      integer itau0
+      PARAMETER(nbpasmx=1000000)
+      REAL temps(nbpasmx),y
+      INTEGER unitlec
+      INTEGER i,j,l,irec,itautot,ierr,iq,n,ff,k
+      real, dimension(:),allocatable :: lat,lon,alt
+      integer:: nout,latdimout,londimout,altdimout,timedimout,timevarout
+      integer:: latdim,londim,altdim,dimid
+      integer:: latvar,lonvar,altvar,timevar
+      integer:: latlen,lonlen,altlen,timelen
+      integer, dimension(4) :: edges,corner,id
+      integer, dimension(3) :: edges2,corner2
+
+      INTEGER   unit,nvarid,nid,varid
+      REAL mugaz
+
+      REAL missing
+      PARAMETER(missing=1E+20)
+      REAL valid_range(2)
+      DATA valid_range /0., 300.0/
+c   variables meteo dans la grille verticale GCM
+c   --------------------------------------------
+      REAL v(iip1,jjp1,llm),u(iip1,jjp1,llm),w(iip1,jjp1,llm)
+      REAL t(iip1,jjp1,llm),rho(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+      REAL ps(iip1,jjp1) , tsurf(iip1,jjp1)
+      REAL Rnew(iip1,jjp1,llm)
+      real euv(iip1,jjp1,llm),con(iip1,jjp1,llm),nir(iip1,jjp1,llm)
+      real nspec(iip1,jjp1,llm,nqmx),spec(iip1,jjp1,llm)
+
+      REAL v_sd(iip1,jjp1,llm),u_sd(iip1,jjp1,llm)
+      real w_sd(iip1,jjp1,llm),t_sd(iip1,jjp1,llm)
+      real rho_sd(iip1,jjp1,llm)
+      real euv_sd(iip1,jjp1,llm),con_sd(iip1,jjp1,llm)
+      real nir_sd(iip1,jjp1,llm)
+      real nspec_sd(iip1,jjp1,llm,nqmx)
+
+c   ALtitude of the GCM levels
+c   -------------------------
+      REAL zlocal(iip1,jjp1,llm) ! altitude above the local surface (m)
+      REAL zareoid(iip1,jjp1,llm) ! altitude above the mola areoid (m)
+      real tmean   ! use to integrate hydrostatic equation
+      real Rmean   ! use to integrate hydrostatic equation
+
+c    Also used to integrate hydrostatic equation:
+      real g0 ! exact mean gravity at radius=3396.km (LEMOINE ET AL 2001) 
+      data    g0 /3.7257964/
+      data    a0 /3396.0/  ! radius=3396.km
+      real gz  ! used to estimate gravity in altitude...
+
+
+c   variables meteo en coordonnee de pression
+c   --------------------------------------------
+      REAL vp(iip1,jjp1,llm),up(iip1,jjp1,llm),wp(iip1,jjp1,llm)
+      REAL tp(iip1,jjp1,llm),rhop(iip1,jjp1,llm)
+      REAL nspecp(iip1,jjp1,llm,nqmx)
+      REAL phip(iip1,jjp1,llm)
+      
+      REAL vp_sd(iip1,jjp1,llm),up_sd(iip1,jjp1,llm)
+      real wp_sd(iip1,jjp1,llm),tp_sd(iip1,jjp1,llm)
+      real rhop_sd(iip1,jjp1,llm),nspecp_sd(iip1,jjp1,llm,nqmx)
+ 
+c     Niveaux de pression (Pa)
+      real pref(llm)
+
+c    Version 32 layers : ************
+c     data pref/
+c     &1000.,884., 783. , 610., 475, 370, 288, 224, 174, 140.,
+c     &115 , 80.6481, 48.0445, 26.6881, 14.1462, 7.29102, 3.70004,
+c     &1.86241, 0.933516, 0.466924, 0.233296, 0.116503, 5.81631E-02,
+c     & 2.90335E-02,1.44919E-02, 7.23328E-03, 3.61027E-03, 1.80193E-03,
+c     & 8.99364E-04,4.48881E-04, 2.15769E-04, 1.3E-04/
+
+c    Version 50 layers : ************
+      data pref/
+     &1400., 1100., 800., 565., 400., 280., 200., 140., 100.,
+     &70., 50., 35., 25., 18., 13., 9., 6.,
+     &3.63227,1.803712,0.8956969,0.4447900,0.2208762,0.1096839,
+     &5.4467395E-02,2.7047679E-02,1.3431421E-02,
+     &6.6698161E-03,3.3121328E-03,
+     &1.6447564E-03,8.1676187E-04,4.0559194E-04,2.0141099E-04,
+     &1.0001774E-04,4.9667346E-05,2.4664072E-05,1.2247816E-05,
+     &6.0820857E-06,3.0202741E-06,1.4998238E-06,7.4479044E-07,
+     &3.6985199E-07,1.8366305E-07,9.1204370E-08,4.5290751E-08,
+     &2.2490720E-08,1.1168562E-08,5.5461431E-09,2.7541311E-09,
+     &1.3676602E-09,6.7915956E-10/
+
+c   variables meteo en coordonnee de zareoid
+c   --------------------------------------------
+      REAL va(iip1,jjp1,llm),ua(iip1,jjp1,llm),wa(iip1,jjp1,llm)
+      REAL ta(iip1,jjp1,llm),rhoa(iip1,jjp1,llm),ra(iip1,jjp1,llm)
+      real euva(iip1,jjp1,llm),cona(iip1,jjp1,llm),nira(iip1,jjp1,llm)
+      real nspeca(iip1,jjp1,llm,nqmx)
+
+      REAL va_sd(iip1,jjp1,llm),ua_sd(iip1,jjp1,llm)
+      real wa_sd(iip1,jjp1,llm),ta_sd(iip1,jjp1,llm)
+      real rhoa_sd(iip1,jjp1,llm)
+      real euva_sd(iip1,jjp1,llm),cona_sd(iip1,jjp1,llm)
+      real nira_sd(iip1,jjp1,llm)
+      real nspeca_sd(iip1,jjp1,llm,nqmx)
+
+      REAL vij(llm),uij(llm),zaij(llm),wij(llm),rij(llm)
+      REAL tij(llm),rhoij(llm+1),sigij(llm)
+      real euvij(llm),conij(llm),nirij(llm)
+      real nspecij(llm+1,nqmx)
+
+      REAL vij_sd(llm),uij_sd(llm)
+      real wij_sd(llm),tij_sd(llm),rhoij_sd(llm+1)
+      real euvij_sd(llm),conij_sd(llm),nirij_sd(llm)
+      real nspecij_sd(llm+1,nqmx)
+
+c     Niveaux de zareoid (m)
+      real zaref(llm)
+      real p_zaref,p_zaij(llm+1) ! used to interpolate rho
+
+       data zaref/    
+      & -6.E+3,-4.E+3,-2.E+3,0.E+3,2.E+3,4.E+3,6.E+3,8.E+3,10.E+3,12.E+3
+      & ,14.E+3,16.E+3,18.E+3,22.E+3,26.E+3,30.E+3,34.E+3
+      & ,38.E+3,44.E+3,50.E+3,56.E+3,62.E+3,68.E+3,74.E+3
+      & ,80.E+3,86.E+3,92.E+3,98.E+3,104.E+3,110.E+3,116.E+3
+      & ,122.E+3,128.E+3,134.E+3,140.E+3,146.E+3,152.E+3,158.E+3
+      & ,164.E+3,170.E+3,176.E+3,182.E+3,188.E+3,194.E+3,200.E+3
+      & ,206.E+3,212.E+3,218.E+3,224.E+3,230.E+3/
+
+
+c   Surface data (sometime needed for some analysis):
+c   ------------------------------------------------
+      character relief*3
+      real phis(iip1,jjp1)
+      real alb(iip1,jjp1),ith(iip1,jjp1)
+      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
+      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
+
+
+      real utime
+      real localtime(iip1)
+      common/temporaire/localtime
+
+      INTEGER*4 day0
+      integer nmoy(jjp1,llm),tp1,tp2,pass
+
+      CHARACTER*1 yes,yescomp
+
+      integer iformat
+       
+c   declarations de l'interface avec mywrite:
+c   -----------------------------------------
+
+      CHARACTER file*80
+      CHARACTER nomfich*60
+      CHARACTER nomfile(2)*60,nomfileout(2)*60
+      integer fichsize,fstats
+      CHARACTER fdiag*60
+
+c   externe:
+c   --------
+
+      EXTERNAL iniconst,inigeom,covcont,mywrite
+      EXTERNAL inifilr,exner
+      EXTERNAL solarlong,coordij,moy2
+      EXTERNAL SSUM
+      REAL SSUM
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+
+c   Dust
+c   ----
+
+#include "fxyprim.h"
+
+      character*10  noms(nqmx),varnoms(6)
+c      data          noms/"co2","co","o","o1d","o2","o3","h","h2",
+c     $                   "oh","ho2","h2o2", "n2", "h2o"/
+c      data          varnoms/"T","U","V","W","RHO","Species"/
+
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      unitlec=11
+      itautot=0
+
+
+c     Lecture du fichier a lire
+c     -------------------------
+
+      print*,' ' 
+      PRINT*,'File to process: 1)DIAGFI 2)STATS 3)BOTH'
+      READ(5,'(i)') fichsize
+      if(fichsize.ne.2)then
+        i=1
+        PRINT*,'   enter name of diagfi file (w/o .nc)'
+        READ(5,'(a)') nomfile(i)
+        fdiag=nomfile(i)
+        PRINT*,'   do you want to rename the output file?  
+     &  1) Yes  2) No'
+        READ(5,'(i)') sor
+        if (sor.eq.1) then
+          PRINT*,'   enter label for output file'
+          READ(5,'(a)') nomfileout(i)
+        elseif(sor.eq.2) then
+          nomfileout(i)=nomfile(i)
+        endif
+      endif
+      if(fichsize.ne.1)then
+        i=i+1
+        PRINT*,'   enter name of stats file (w/o .nc)'
+        READ(5,'(a)') nomfile(i)
+        PRINT*,'   do you want to rename the output file?  
+     &  1) Yes  2) No'
+        READ(5,'(i)') sor
+        if (sor.eq.1) then
+          PRINT*,'   enter label for output file'
+          READ(5,'(a)') nomfileout(i)
+        elseif(sor.eq.2) then
+          nomfileout(i)=nomfile(i)
+        endif
+        if(fichsize.eq.2) then
+          PRINT*,'   enter name of diagfi file for controle (w/o .nc)'
+          read(5,'(a)') fdiag
+        endif
+        fstats=1
+      endif
+      if (fichsize.ge.2) fichsize=fichsize-1
+      print*,' '
+      print*,'Output in: 1) netcdf 2) IDL 3) both ?'
+      READ(5,'(i)') sor
+      print*,' '
+      print*,'Coordinates in: 1) pressure 2) Zareoid 3) both  ?'
+      READ(5,'(i)') coor
+
+c ************* Partie a moderniser !!! FF 2004 ************
+      print*,' '
+      print*,'Fields:  T  U  V  W  Rho  Species  All   ?'
+      print*,'Type total number of desired outputs or 6 for All   '
+      READ(5,'(i)') varoutsize
+      if(varoutsize.lt.6) then
+        print*,' '
+        print*,'Fields:  T  U  V  W  Rho  Species '
+        print*,'  #   :  1  2  3  4   5      6'
+        print*,' '
+        do i=1,varoutsize
+          print*,'Type number of variable ',i
+          READ(5,'(i)') varout(i)
+        enddo
+      endif
+      if(varoutsize.eq.6) then
+        do i=1,6
+          varout(i)=i
+        enddo
+      endif
+      do i=1,varoutsize
+        if (varout(i).eq.6) then
+           print*,'Type total number of desired species or 13 for All'
+           READ(5,'(i2)') varspecsize
+           if(varspecsize.ne.13) then
+             print*,' '
+             print*,'Select Species: CO2 CO O O(1D) O2 O3' 
+             print*,'                 1  2  3   4   5  6'
+             print*,'                 H H2 OH HO2 H2O2 N2 H2O'
+             print*,'                 7 8  9  10   11  12 13'
+             do n=1,varspecsize
+               print*,'Type number of species ',i
+               read(5,'(i)') varspec(n)
+             enddo
+           else
+             do n=1,varspecsize
+               varspec(n)=n
+             enddo
+           endif
+         endif
+       enddo
+      if(varoutsize.gt.6) print*,'Value must be <= 6'
+     
+c ***************** Fin partie a moderniser ***************
+
+! LOOP ON FILES
+! =================================================================
+      do ff=1,fichsize
+ 
+      file=nomfile(ff)  
+      nomfich=nomfile(ff)  
+      file=file(1:lnblnk(file))
+      PRINT*,'file',file
+
+c     Ouverture fichiers :
+c     ------------------
+      write(*,*) "opening "//trim(nomfich)//"..."
+      ierr = NF_OPEN(trim(adjustl(nomfich))//".nc",NF_NOWRITE,nid)
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: Pb opening file '//nomfich
+         stop ""
+      endif
+
+! Control & lecture on dimensions
+! =================================================================
+      ierr=NF_INQ_DIMID(nid,"latitude",latdim)
+      ierr=NF_INQ_VARID(nid,"latitude",latvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <latitude> is missing'
+      stop ""
+      endif
+      ierr=NF_INQ_DIMLEN(nid,latdim,latlen)
+!  write(*,*) "latlen: ",latlen
+
+      ierr=NF_INQ_DIMID(nid,"longitude",londim)
+      ierr=NF_INQ_VARID(nid,"longitude",lonvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <longitude> is lacking'
+      stop ""
+      endif
+      ierr=NF_INQ_DIMLEN(nid,londim,lonlen)
+!  write(*,*) "lonlen: ",lonlen
+
+      ierr=NF_INQ_DIMID(nid,"altitude",altdim)
+      ierr=NF_INQ_VARID(nid,"altitude",altvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <altitude> is lacking'
+      stop ""
+      endif
+
+      ierr=NF_INQ_DIMLEN(nid,altdim,altlen)
+!  write(*,*) "altlen: ",altlen
+
+      if (ff.eq.1) then
+        allocate(lat(latlen))
+        allocate(lon(lonlen))
+        allocate(alt(altlen))
+      endif
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid,latvar,lat)
+      ierr = NF_GET_VAR_DOUBLE(nid,lonvar,lon)
+      ierr = NF_GET_VAR_DOUBLE(nid,altvar,alt)
+#else
+      ierr = NF_GET_VAR_REAL(nid,latvar,lat)
+      ierr = NF_GET_VAR_REAL(nid,lonvar,lon)
+      ierr = NF_GET_VAR_REAL(nid,altvar,alt)
+#endif
+
+c   Lecture Time :
+
+      ierr= NF_INQ_DIMID (nid,"Time",dimid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'anl_NC: Le champ <Time> est absent'
+          CALL abort
+        ENDIF
+
+      ierr= NF_INQ_DIMLEN (nid,dimid,nbpas)
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, temps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, temps)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'anl_NC: Lecture echouee pour <Time>'
+          CALL abort
+        ENDIF
+        PRINT*,'temps',(temps(itau),itau=1,10)
+! =================================================================
+
+! SETTING OUTPUT FILES
+
+      file=nomfileout(ff)  
+      nomfich=nomfileout(ff)  
+      file=file(1:lnblnk(file))
+
+c    layers in zareoid : ************
+          do l=1,llm
+            alt(l)=zaref(l)/1000.
+          enddo
+
+! =================================================================
+! Output in netcdf
+! =================================================================
+      if (sor.ne.2) then
+
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+ 
+          ierr = NF_CREATE(trim(adjustl(nomfich))//"_P.nc",
+     &                     NF_CLOBBER, nout)
+          if (ierr.NE.NF_NOERR) THEN
+            write(*,*)' Pb d''ouverture du fichier '
+            write(*,*)' ierr = ', ierr
+            STOP
+          ENDIF
+          ierr = NF_PUT_ATT_TEXT(nout, NF_GLOBAL, "title", 24,
+     &                          "Pressure coordinates ")
+          ierr = NF_DEF_DIM(nout,"latitude", size(lat), latdimout)
+          ierr = NF_DEF_DIM(nout,"longitude", size(lon), londimout)
+          ierr = NF_DEF_DIM(nout,"altitude", size(pref), altdimout)
+          ierr = NF_DEF_DIM(nout,"Time", NF_UNLIMITED, timedimout)
+          ierr = NF_ENDDEF(nout)
+
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES 
+
+          ierr = NF_CREATE(trim(adjustl(nomfich))//"_Z.nc",
+     &                     NF_CLOBBER, nout)
+          IF(ierr.NE.NF_NOERR) THEN
+            write(*,*)' Pb d''ouverture du fichier '
+            write(*,*)' ierr = ', ierr
+            STOP
+          ENDIF
+          ierr = NF_PUT_ATT_TEXT(nout, NF_GLOBAL, "title", 24,
+     &                           "zaeroid coordinates")
+          ierr = NF_DEF_DIM(nout,"latitude", size(lat), latdimout)
+          ierr = NF_DEF_DIM(nout,"longitude", size(lon), londimout)
+          ierr = NF_DEF_DIM(nout,"altitude ", size(pref), altdimout)
+          ierr = NF_DEF_DIM(nout,"Time", NF_UNLIMITED, timedimout)
+          ierr = NF_ENDDEF(nout)
+
+        endif
+
+        call def_var(nout,"Time","Time","days since 0000-00-0
+     &  00:00:00",1,(/timedimout/),timevarout,ierr)
+
+        ierr = NF_REDEF (nout)       
+        call def_var(nout,"latitude","latitude","degrees_north",1,
+     &               (/latdimout/),nvarid,ierr)
+
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,lat)
+#else
+        ierr = NF_PUT_VAR_REAL (nout,nvarid,lat)
+#endif
+        ierr = NF_REDEF (nout) 
+        call def_var(nout,"longitude","East longitude","degrees_east",1,
+     &               (/londimout/),nvarid,ierr)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,lon)
+#else
+        ierr = NF_PUT_VAR_REAL (nout,nvarid,lon)
+#endif
+        ierr = NF_REDEF (nout)
+
+        if(coor.ne.2) then 					! PRESSURE CCOORDINATES
+#ifdef NC_DOUBLE
+          ierr = NF_DEF_VAR (nout,"altitude",NF_DOUBLE,1,
+     &                       (/altdimout/), nvarid)
+#else
+          ierr = NF_DEF_VAR (nout,"altitude",NF_FLOAT,1,
+     &                       (/altdimout/),nvarid)
+#endif
+
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,"long_name",22,"altitude
+     &                            pression")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'units',2,"Pa")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'positive',4,"down")
+          ierr = NF_ENDDEF(nout)
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,pref)
+#else
+          ierr = NF_PUT_VAR_REAL (nout,nvarid,pref)
+#endif
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES 
+
+#ifdef NC_DOUBLE
+          ierr = NF_DEF_VAR (nout,"altitude",NF_DOUBLE,1,
+     &                       (/altdimout/), nvarid)
+#else
+          ierr = NF_DEF_VAR (nout,"altitude",NF_FLOAT,1,
+     &                       (/altdimout/),nvarid)
+#endif
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,"long_name",20,"altitude
+     &                           zaeroid")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'units',2,"km")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'positive',2,"up")
+          ierr = NF_ENDDEF(nout)
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,alt)
+#else
+          ierr = NF_PUT_VAR_REAL (nout,nvarid,alt)
+#endif
+        endif
+
+      endif !end if netcdf  
+
+! Output in idl
+! =================================================================
+      if (sor.ne.1) then
+
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+          do i=1,varoutsize
+            j=121+i
+            if(varout(i).eq.6) then
+              do iq=1,varspecsize
+                file=trim(nomfileout(ff))//'_P_'
+     &               //trim(noms(iq))//'.dat'  
+                j=121+i+(iq-1)
+                open(j,file=trim(file), status='unknown')
+                write(j,117) noms(iq) 
+                write(j,120) iim,jjp1,llm
+                write(j,119) lon
+                write(j,119) lat
+                write(j,119) pref
+              enddo
+            else
+              file=trim(nomfileout(ff))//'_P_'
+     &            //trim(varnoms(varout(i)))//'.dat'  
+              open(j,file=trim(file), status='unknown')
+              write(j,117) varnoms(varout(i)) 
+              write(j,120) iim,jjp1,llm
+              write(j,119) lon
+              write(j,119) lat
+              write(j,119) pref
+            endif
+          enddo 
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES
+          do i=1,varoutsize
+            j=1221+i
+            if(varout(i).eq.6) then
+              do iq=1,varspecsize
+                file=trim(nomfileout(ff))//'_Z_'
+     &               //trim(noms(iq))//'.dat'  
+                j=1221+i+(iq-1)
+                open(j,file=trim(file), status='unknown')
+                write(j,117) noms(iq)
+                write(j,120) iim,jjp1,llm
+                write(j,119) lon
+                write(j,119) lat
+                write(j,119) alt
+              enddo
+            else
+              file=trim(nomfileout(ff))//'_Z_'
+     &            //trim(varnoms(varout(i)))//'.dat'  
+              open(j,file=trim(file), status='unknown')
+              write(j,117) varnoms(varout(i))
+              write(j,120) iim,jjp1,llm
+              write(j,119) lon
+              write(j,119) lat
+              write(j,119) alt
+            endif
+          enddo
+              
+c              file=trim(nomfileout(ff))
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_EUV.dat',
+c     &               status='unknown')
+c              write(j,117) 'EUV'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_CON.dat',
+c     &               status='unknown')
+c              write(j,117) 'CONDUCTION'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_NIR.dat',
+c     &               status='unknown')
+c              write(j,117) 'NIR'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+        endif
+
+      endif
+120    format(3i3)
+119    format(12(e10.4,1x))
+118    format(2i3)
+117    format(6(a7))
+116    format(13(a6))
+! =================================================================
+ 
+
+800   continue ! LOOP SUR LES FICHIERS
+
+
+! =================================================================
+! INITIALIZATION OF PARAMETERS
+! =================================================================
+
+      rad=3397200.              ! rayon de mars (m)  ~3397200 m
+      daysec=88775.             ! duree du sol (s)  ~88775 s
+      omeg=4.*asin(1.)/(daysec) ! vitesse de rotation (rad.s-1)
+      g=3.72                    ! gravite (m.s-2) ~3.72
+      mugaz=43.49               ! Masse molaire de l'atm (g.mol-1) ~43.49
+      kappa=.256793             ! = r/cp  ~0.256793
+      r = 191.18213
+      pi=2.*asin(1.)
+      ecritphy =1
+      iphysiq=1
+      day_ini=0.
+      day_step=1
+
+      CALL readhead_NC(trim(adjustl(fdiag))//".nc",day0,phis,R)
+      WRITE (*,*) 'day0 = ' , day0
+
+      CALL iniconst
+      CALL inigeom
+      CALL inifilr
+
+c     If needed : getting topography, albedo, thermal inertia...
+c     -------------------------------------------------------
+c     "phis" is the surface geopotential = topography (m) * g 
+       relief='mola'    ! Topography MOLA par defaut
+
+        CALL datareadnc(relief,phis,alb,ith,zmeaS,zstdS,zsigS,zgamS,
+      .          ztheS)
+
+
+! =================================================================
+! LOOP IN TIME
+! =================================================================
+
+      DO itau=1,nbpas
+
+! FILE READING : 
+! =================================================================
+        print*,'Timestep = ',itau,'/',nbpas
+
+c Cas special stats pour la base de donnee : FF 2004
+c        call lect_var(nid,'tsurf',3,ierr,itau,	tsurf)
+        call lect_var(nid,'ps',3,ierr,itau,ps)
+
+        call lect_var(nid,'temp',4,ierr,itau,t)
+        call lect_var(nid,'u',4,ierr,itau,u)
+        call lect_var(nid,'v',4,ierr,itau,v)
+        call lect_var(nid,'w',4,ierr,itau,		w)
+        call lect_var(nid,'rho',4,ierr,itau,	rho)
+        
+
+
+        do n=1,varspecsize
+          i=varspec(n)
+        call lect_var(nid,'n_'//trim(noms(i)),4,ierr,itau,spec)
+        do l=1,llm
+          do j=1,jjp1
+            do i=1,iip1
+              nspec(i,j,l,n)=spec(i,j,l)
+            enddo
+          enddo
+        enddo
+        enddo
+
+        if(fstats*ff-fichsize .eq. 0) then
+          call lect_var(nid,'temp_sd',4,ierr,itau,	t_sd)
+          call lect_var(nid,'u_sd',4,ierr,itau,		u_sd)
+          call lect_var(nid,'v_sd',4,ierr,itau,		v_sd)
+c          call lect_var(nid,'w_sd',4,ierr,itau,		w_sd)
+c          call lect_var(nid,'rho_sd',4,ierr,itau,	rho_sd)
+          do n=1,varspecsize
+            i=varspec(n)
+            call lect_var(nid,'n_'//trim(noms(i))//'_sd',4,ierr,
+     &                    itau,	spec)
+            do l=1,llm
+              do j=1,jjp1
+                do i=1,iip1
+                  nspec_sd(i,j,l,n)=spec(i,j,l)
+                enddo
+              enddo
+            enddo
+          enddo
+        endif
+
+! =================================================================
+! COMPUTING ALTITUDE OF GCM LEVELS IN GCM GRID
+! =================================================================
+
+c  ---------------------------------------------------------------
+c   Computing Molecular Gas Constant at every grid point (J kg-1 K-1)
+c   later used to integrate the hydrostatic equation
+c  ---------------------------------------------------------------
+        do l=1,llm
+          do j=1,jjp1
+            do i=1,iip1
+c              Rnew = P/(rho*T)
+              Rnew(i,j,l) =  (aps(l) + bps(l)*ps(i,j))
+     &                      / ( rho(i,j,l) * T(i,j,l) )
+            enddo
+          enddo
+        enddo
+
+
+c      ALTITUDE OF GCM LEVELS 
+c      ----------------------
+c      zlocal 	! altitude above the local surface (m)
+c      zareoid 	! altitude above the mola areoid (m)
+c      phis(i,j)/g ! altitude of the local surface above the mola areoid (m)
+
+        do j=1,jjp1
+          do i=1,iip1
+            sigij(1)=aps(1)/ps(i,j)+bps(1)
+            zlocal(i,j,1)=-log(sigij(1))* Rnew(i,j,1)*t(i,j,1)/g
+            zareoid(i,j,1) = zlocal(i,j,1) + phis(i,j)/g0
+
+            do l=2,llm
+              sigij(l)=aps(l)/ps(i,j)+bps(l)
+              tmean=t(i,j,l)
+              if(t(i,j,l).ne.t(i,j,l-1))
+     &          tmean=(t(i,j,l)-t(i,j,l-1))/log(t(i,j,l)/t(i,j,l-1))
+                Rmean = 0.5*(Rnew(i,j,l) + Rnew(i,j,l-1))
+                gz= g0*a0**2/(a0+zareoid(i,j,l-1))**2
+
+              zlocal(i,j,l)=zlocal(i,j,l-1) 
+     &                -log(sigij(l)/sigij(l-1))*Rmean*tmean/gz
+              zareoid(i,j,l) = zlocal(i,j,l) + phis(i,j)/g
+            enddo
+  
+          enddo
+        enddo
+
+
+c Local time
+c ----------
+c universal time (in stats oe MCD files)
+        utime = (itau-1)*2.
+
+c local time (in stats file)
+        DO i = 1,iim
+          localtime(i)=utime + 12.*rlonv(i)/pi
+          if(localtime(i).gt.24) localtime(i)=localtime(i)-24.
+          if(localtime(i).lt.0) localtime(i)=localtime(i)+24.
+        ENDDO
+
+c c Passage en niveaux de pression
+c ------------------------------
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+          call xsig2p (ps,T,pref,llm,Tp)
+          call xsig2p (ps,u,pref,llm,up)
+          call xsig2p (ps,v,pref,llm,vp)
+          call xsig2p (ps,w,pref,llm,wp)
+          call xsig2p (ps,rho,pref,llm,rhop)
+          do iq=1,varspecsize
+            call xsig2p (ps,nspec(1,1,1,iq),pref,llm,nspecp(1,1,1,iq))
+          enddo
+           if(fstats*ff-fichsize .eq. 0) then
+             call xsig2p (ps,u_sd,pref,llm,up_sd)
+             call xsig2p (ps,v_sd,pref,llm,vp_sd)
+             call xsig2p(ps,t_sd,pref,llm,Tp_sd)
+             call xsig2p (ps,w_sd,pref,llm,wp_sd)
+             call xsig2p (ps,rho_sd,pref,llm,rhop_sd)
+             do iq=1,varspecsize
+               call xsig2p (ps,nspec_sd(1,1,1,iq),pref,llm,
+     $                      nspecp_sd(1,1,1,iq))
+             enddo
+           endif
+         endif
+
+c c Passage en niveaux de zareoid
+c ------------------------------
+        if(coor.ne.1) then 					! ZAEROID COORDINATES
+        do j=1,jjp1
+          do i=1,iip1
+            do l=1,llm
+              Tij(l)=T(i,j,l)
+              uij(l)=u(i,j,l)
+              vij(l)=v(i,j,l)
+              wij(l)=w(i,j,l)
+              rhoij(l)=rho(i,j,l)
+              do iq=1,varspecsize
+                nspecij(l,iq)=nspec(i,j,l,iq)
+                if(l.eq.llm) nspecij(l+1,iq)=nspecij(l,iq)*1.e-3
+              enddo
+c              euvij(l)=euv(i,j,l)
+c              conij(l)=con(i,j,l)
+c              nirij(l)=nir(i,j,l)
+              zaij(l)=zareoid(i,j,l)
+              p_zaij(l)=exp(-zareoid(i,j,l)/1.e4) ! used to interpolate rho
+              if(fstats*ff-fichsize .eq. 0) then
+                Tij_sd(l)=T_sd(i,j,l)
+                uij_sd(l)=u_sd(i,j,l)
+                vij_sd(l)=v_sd(i,j,l)
+                wij_sd(l)=w_sd(i,j,l)
+                rhoij_sd(l)=rho_sd(i,j,l)
+                do iq=1,varspecsize
+                  nspecij_sd(l,iq)=nspec_sd(i,j,l,iq)
+                  if(l.eq.llm) nspecij_sd(l+1,iq)=nspecij_sd(l,iq)*1.e-3
+                enddo
+              endif
+            enddo
+
+            do l=1,llm
+              call interpolf(zaref(l),y,zaij,Tij,llm)
+              Ta(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,uij,llm)
+              ua(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,vij,llm)
+              va(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,wij,llm)
+              wa(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,euvij,llm)
+c              euva(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,conij,llm)
+c              cona(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,nirij,llm)
+c              nira(i,j,l)=y
+
+              p_zaref=exp(-zaref(l)/1.e4)
+              call interpolf(p_zaref,y,p_zaij,rhoij,llm+1)
+              rhoa(i,j,l)=y
+               
+              do iq=1,varspecsize
+                call interpolf(p_zaref,y,p_zaij,nspecij(1,iq),llm+1)
+c                call interpolf(zaref(l),y,zaij,nspecij(1,iq),llm)
+                nspeca(i,j,l,iq)=y
+              enddo
+
+              if(fstats*ff-fichsize .eq. 0) then
+                call interpolf(zaref(l),y,zaij,Tij_sd,llm)
+                Ta_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,uij_sd,llm)
+                ua_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,vij_sd,llm)
+                va_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,wij_sd,llm)
+                wa_sd(i,j,l)=y
+                call interpolf(p_zaref,y,p_zaij,rhoij_sd,llm+1)
+                rhoa_sd(i,j,l)=y
+                do iq=1,varspecsize
+                  call interpolf(p_zaref,y,p_zaij,nspecij_sd(1,iq),
+     &                           llm+1)
+c                  call interpolf(zaref(l),y,zaij,nspecij_sd(1,iq),llm)
+                  nspeca_sd(i,j,l,iq)=y
+                enddo
+              endif
+
+            enddo
+          enddo
+        enddo
+
+c            do l=1,llm
+c        print*,T(32,24,l),Ta(32,24,l)
+c        print*,nspec(32,24,l,1),nspeca(32,24,l,1)
+c            enddo
+
+        endif
+ 
+c Output at each time-step, in netcdf format
+! =================================================================
+        if (sor .ne. 2) then
+
+          ierr= NF_INQ_VARID(nout,"Time",nvarid)
+#ifdef NC_DOUBLE
+          ierr= NF_PUT_VARA_DOUBLE(nout,nvarid,itau,1,temps(itau))
+#else
+          ierr= NF_PUT_VARA_REAL(nout,nvarid,itau,1,temps(itau))
+#endif
+          if (ierr.ne.NF_NOERR) then
+            write(*,*) "time problem ",NF_STRERROR(ierr)
+            stop
+          endif
+
+          if (varoutsize.eq.6) n=1
+          if (varoutsize.ne.6) n=varoutsize
+          do i=1,n
+            if(varout(i).eq.1 .or. varoutsize.eq.6) then
+             if(coor.ne.1) 
+     &          call put_var(nout,'temp','temp','K',4,ierr,itau,Ta)
+             if(coor.ne.2) 
+     &          call put_var(nout,'temp','temp','K',4,ierr,itau,Tp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'temp_sd','temp_sd','K',
+     &                                      4,ierr,itau,Ta_sd)
+                if(coor.ne.2) call put_var(nout,'temp_sd','temp_sd','K',
+     &                                      4,ierr,itau,Tp_sd)
+              endif
+            endif
+            if(varout(i).eq.2 .or. varoutsize.eq.6)  then
+              if(coor.ne.1) 
+     &          call put_var(nout,'u','u','m s-1',4,ierr,itau,ua)
+              if(coor.ne.2) 
+     &          call put_var(nout,'u','u','m s-1',4,ierr,itau,up)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'u_sd','u_sd','m s-1',
+     &                                      4,ierr,itau,ua_sd)
+                if(coor.ne.2) call put_var(nout,'u_sd','u_sd','m s-1',
+     &                                      4,ierr,itau,up_sd)
+              endif
+            endif
+            if(varout(i).eq.3 .or. varoutsize.eq.6) then
+              if(coor.ne.1) 
+     &          call put_var(nout,'v','v','m s-1',4,ierr,itau,va)
+              if(coor.ne.2) 
+     &          call put_var(nout,'v','v','m s-1',4,ierr,itau,vp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'v_sd','v_sd','m s-1',
+     &                                      4,ierr,itau,va_sd)
+                if(coor.ne.2) call put_var(nout,'v_sd','v_sd','m s-1',
+     &                                      4,ierr,itau,vp_sd)
+              endif
+            endif
+            if(varout(i).eq.4 .or. varoutsize.eq.6) then
+              if(coor.ne.1) 
+     &          call put_var(nout,'w','w','m s-1',4,ierr,itau,wa)
+              if(coor.ne.2) 
+     &          call put_var(nout,'w','w','m s-1',4,ierr,itau,wp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'w_sd','w_sd','m s-1',
+     &                                      4,ierr,itau,wa_sd)
+                if(coor.ne.2) call put_var(nout,'w_sd','w_sd','m s-1',
+     &                                      4,ierr,itau,wp_sd)
+              endif
+            endif
+            if(varout(i).eq.5 .or. varoutsize.eq.6)  then
+              if(coor.ne.1) call put_var(nout,'rho','rho','',4,ierr,
+     &                                    itau,rhoa)
+              if(coor.ne.2) call put_var(nout,'rho','rho','',4,ierr,
+     &                                    itau,rhop)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'rho_sd','rho_sd','',
+     &                                      4,ierr,itau,rhoa_sd)
+                if(coor.ne.2) call put_var(nout,'rho_sd','rho_sd','',
+     &                                      4,ierr,itau,rhop_sd)
+              endif
+            endif
+            if(varout(i).eq.6 .or. varoutsize.eq.6) then
+              do iq=1,varspecsize
+                j=varspec(iq)
+                if(coor.ne.1) call put_var(nout,'n_'//trim(noms(j)),
+     &       'n_'//trim(noms(j)),'cm-3',4,ierr,itau,nspeca(1,1,1,iq))
+                if(coor.ne.2) call put_var(nout,'n_'//trim(noms(j)),
+     &         'n_'//trim(noms(j)),'cm-3',4,ierr,itau,nspecp(1,1,1,iq))
+                if(fstats*ff-fichsize.eq.0) then
+                  if(coor.ne.1) call put_var(nout,
+     &                        'n_'//trim(noms(j))//'_sd',
+     &                        'n_'//trim(noms(j))//'_sd','cm-3',4,ierr,
+     &                           itau,nspeca_sd(1,1,1,iq))
+                  if(coor.ne.2) call put_var(nout,
+     &                        'n_'//trim(noms(j))//'_sd',
+     &                        'n_'//trim(noms(j))//'_sd','cm-3',4,ierr,
+     &                           itau,nspecp_sd(1,1,1,iq))
+                endif
+              enddo
+            endif     
+          enddo
+        endif !endif writing data on Netcdf file 
+
+c Output at each time-step, ASCII file for IDL
+! =================================================================
+c In pressure and zareoid coordinates:
+
+      if (sor .ne. 1) then
+       do n=1,varoutsize
+         if(varout(n).eq.1) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((Tp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((Ta(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.2) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((up(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1)then
+               k=1221+n
+               write(k,124) ((ua(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif 
+         if(varout(n).eq.3) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((vp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((va(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.4) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(122,124) ((wp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((wa(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.5) then
+           do l=1,llm
+            if(coor.ne.2) then
+              k=121+n
+              write(k,124) ((rhop(i,j,l),i=1,iim),j=1,jjp1)
+            elseif(coor.ne.1) then
+               k=1221+n
+              write(k,124) ((rhoa(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.6) then
+           do iq=1,varspecsize
+             do l=1,llm
+               if(coor.ne.1) then
+                 k=1221+n+(iq-1)
+                 write(k,124) ((nspeca(i,j,l,iq),i=1,iim),j=1,jjp1)
+               endif
+             enddo
+           enddo
+         endif     
+       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((euva(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((cona(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((nira(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+      endif
+124   format(12(e10.4,1x))
+
+
+       ENDDO		!LOOP in TIME
+! =================================================================
+
+ 900   continue
+
+
+c  ECRITURE FINALE si besoin
+c  *************************
+      ierr= NF_CLOSE(nid)
+      ierr=NF_CLOSE(nout)
+      close (33)
+      close (122)
+      close (1222)
+       
+      ENDDO		!LOOP in FILES
+! =================================================================
+
+9999  PRINT*,'Fin '
+1000  format(a5,3x,i4,i3,x,a39)
+7777  FORMAT ('latitude/longitude',4f7.1)
+
+      END
+
+c*******************************************************
+
+      subroutine  xsig2p (ps,qsig,pref,npref,qp)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Francois Forget    Avril 1996
+c
+c Cette subroutine calcule les champs interpole en niveaux de pression
+c different niveaux de pression pref
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c  ARGUMENTS
+c  ---------
+
+c Inputs:
+      
+      REAL qsig(iip1,jjp1,llm)
+      REAL ps(iip1,jjp1)
+      integer npref
+      real pref(npref)
+
+c outputs
+      REAL qp(iip1,jjp1,npref)
+
+
+c Variables du modele
+c -------------------
+
+      REAL lnp(llm)  , q(llm)
+      REAL x,y
+      INTEGER i,j,l ,n
+
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+ 
+#include "fxyprim.h"
+c**********************************************************************
+         if (firstcall) then
+           write(*,*) 'kappa = ', kappa
+           write(*,*) 'cpp = ', cpp
+           firstcall = .false.
+         end if
+
+        DO j=1,jjp1
+          DO i=1,iip1
+            do l=1,llm
+              lnp(l) = -log(aps(l)+bps(l)*ps(i,j))
+              q(l) = qsig(i,j,l)
+            end do
+            do n =1,npref
+              if ( (pref(n).le.ps(i,j)) .and.
+     &          (pref(n).ge.(ps(i,j)*bps(llm)+aps(llm))) ) then
+                    x = -log(pref(n))
+                    call interpolf(x,y,lnp,q,llm)
+                    qp(i,j,n) = y
+              else
+                    qp(i,j,n) = 1E+20 
+              end if
+            end do
+          ENDDO
+        ENDDO
+
+      return
+      end 
+
+      subroutine  missing_value(nout,nvarid,valid_range,missing)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+      include "netcdf.inc"
+
+      INTEGER nout,nvarid,ierr
+      REAL missing
+      REAL valid_range(2)
+c
+c  ARGUMENTS
+c  ---------
+
+c Inputs:
+      
+             ierr= NF_PUT_ATT_REAL(nout,nvarid,'valid_range',
+     $  NF_FLOAT,2,valid_range)
+        IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'anl_NC: valid_range attribution failed'
+            WRITE(*,*) 'NF_NOERR', NF_NOERR
+            CALL abort
+        ENDIF
+
+#ifdef NC_DOUBLE
+             ierr= NF_PUT_ATT_DOUBLE(nout,nvarid,'missing_value',
+     $  NF_DOUBLE,1,missing)
+#else
+              ierr= NF_PUT_ATT_REAL(nout,nvarid,'missing_value',
+     $  NF_FLOAT,1,missing)
+
+#endif
+
+        IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'anl_NC: missing value attribution failed'
+            WRITE(*,*) 'NF_NOERR', NF_NOERR
+            CALL abort
+        ENDIF
+      return
+      end
+**********************************************************
+      subroutine lect_var(nid,name,nbdim,ierr,itau,
+     $ var)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c inputs
+      character (len=*) :: name
+      INTEGER nid,nbdim,nvarid,ierr,itau
+      integer, dimension(nbdim) :: edges,corner
+c output var
+      integer, dimension(nbdim) :: var
+c  ---------
+        if (nbdim.eq.4) then
+         corner=(/1,1,1,itau/)
+         edges=(/iip1,jjp1,llm,1/)
+        endif
+
+        if (nbdim.eq.3) then
+            corner=(/1,1,itau/)
+            edges=(/iip1,jjp1,1/)
+        endif
+
+
+          ierr = NF_INQ_VARID (nid,adjustl(name), nvarid)
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid, nvarid,corner,edges, var)
+#else
+          ierr = NF_GET_VARA_REAL(nid, nvarid,corner,edges, var)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+            write(*,*) 'anl_NC: reading failed for ', name
+            CALL abort
+          ENDIF
+
+      return
+      end
+
+
+      subroutine put_var(nout,name,title,units,nbdim,ierr,itau,
+     $ var)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+      character (len=*) :: title,units,name
+      INTEGER nout,nbdim,nvarid,ierr,itau
+      integer, dimension(nbdim) :: edges,corner,id,var
+      REAL valid_range(2)
+      DATA valid_range /0., 300.0/
+c  ---------
+        if (nbdim.eq.4) then
+         ierr= NF_INQ_DIMID(nout,"longitude",id(1))
+         ierr= NF_INQ_DIMID(nout,"latitude",id(2))
+         ierr= NF_INQ_DIMID(nout,"altitude",id(3))
+         ierr= NF_INQ_DIMID(nout,"Time",id(4))
+         corner=(/1,1,1,itau/)
+         edges=(/iip1,jjp1,llm,1/)
+        endif
+
+        if (nbdim.eq.3) then
+             ierr= NF_INQ_DIMID(nout,"longitude",id(1))
+             ierr= NF_INQ_DIMID(nout,"latitude",id(2))
+             ierr= NF_INQ_DIMID(nout,"Time",id(3))
+            corner=(/1,1,itau/)
+            edges=(/iip1,jjp1,1/)
+        endif
+
+
+        ierr = NF_INQ_VARID (nout,adjustl(name), nvarid)
+          if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+! Creation de la variable si elle n'existait pas
+             write (*,*) "====================="
+             write (*,*) "creation de  ",name
+         call def_var(nout,adjustl(title),adjustl(name),adjustl(units),
+     $   nbdim,id,nvarid,ierr)
+          if (name.eq.'temp') then
+             ierr = NF_REDEF (nout)
+             call missing_value(nout,nvarid,valid_range,1E+20)
+             ierr = NF_ENDDEF(nout)
+          endif
+          endif
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nout,nvarid,corner,edges,var)
+#else
+        ierr = NF_PUT_VARA_REAL(nout,nvarid,corner,edges,var)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+            write(*,*) 'anl_NC: writing failed for ',name
+            CALL abort
+        ENDIF
+
+                
+      return
+      end
+
+
+      Subroutine interpolf(x,y,xd,yd,nd)
+
+c******************************************************
+c   SUBROUTINE   (interpol)
+c interpolation, give y = f(x) with array xd,yd known, size nd
+
+c  Version with CONSTANT values oustide limits
+c**********************************************************
+
+
+c Variable declaration
+c --------------------
+c  Arguments :
+      real x,y
+      real xd(*),yd(*)
+      integer nd
+c  internal
+      integer i,j
+      real y_undefined
+
+c run
+c ---
+c      y_undefined=-999.999
+      y_undefined=1.e20
+
+      y=0.
+      if ((x.le.xd(1)).and.(x.le.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = y_undefined ! yd(1)
+        if (xd(1).ge.xd(nd)) y = y_undefined ! yd(nd)
+      else if ((x.ge.xd(1)).and.(x.ge.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = y_undefined ! yd(nd)
+        if (xd(1).ge.xd(nd)) y = y_undefined ! yd(1)
+c       y = yd(nd)
+      else
+        do i=1,nd-1
+         if ( ( (x.ge.xd(i)).and.(x.lt.xd(i+1)) )
+     &     .or. ( (x.le.xd(i)).and.(x.gt.xd(i+1)) ) ) then
+           y=yd(i)+(x-xd(i))*(yd(i+1)-yd(i))/(xd(i+1)-xd(i))
+           goto 99
+         end if
+        end do
+      end if
+
+c     write (*,*)' x , y' , x,y
+c     do i=1,nd
+c       write (*,*)' i, xd , yd' , xd(i),yd(i)
+c     end do
+c     stop
+
+ 99   continue
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_stats-diag.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_stats-diag.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anl_stats-diag.F	(revision 57)
@@ -0,0 +1,1377 @@
+      PROGRAM anldiag_nc
+      IMPLICIT NONE
+c======================================================================
+c
+c
+c Program designed to read output files from the MARS gcm
+c or the Mars Climate database.
+c
+c    Francois Forget 1999
+c    Version used by monica to interpolate in zaeroid and p coordinate
+
+c
+c=======================================================================
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "netcdf.inc"
+
+      INTEGER itau,nbpas,nbpasmx, coor,sor,varoutsize
+      integer varspecsize
+      integer varout(6),varspec(nqmx)
+      integer itau0
+      PARAMETER(nbpasmx=1000000)
+      REAL temps(nbpasmx),y
+      INTEGER unitlec
+      INTEGER i,j,l,irec,itautot,ierr,iq,n,ff,k
+      real, dimension(:),allocatable :: lat,lon,alt
+      integer:: nout,latdimout,londimout,altdimout,timedimout,timevarout
+      integer:: latdim,londim,altdim,dimid
+      integer:: latvar,lonvar,altvar,timevar
+      integer:: latlen,lonlen,altlen,timelen
+      integer, dimension(4) :: edges,corner,id
+      integer, dimension(3) :: edges2,corner2
+
+      INTEGER   unit,nvarid,nid,varid
+      REAL mugaz
+
+      REAL missing
+      PARAMETER(missing=1E+20)
+      REAL valid_range(2)
+      DATA valid_range /0., 300.0/
+c   variables meteo dans la grille verticale GCM
+c   --------------------------------------------
+      REAL v(iip1,jjp1,llm),u(iip1,jjp1,llm),w(iip1,jjp1,llm)
+      REAL t(iip1,jjp1,llm),rho(iip1,jjp1,llm),phi(iip1,jjp1,llm)
+      REAL ps(iip1,jjp1) , tsurf(iip1,jjp1)
+      REAL Rnew(iip1,jjp1,llm)
+      real euv(iip1,jjp1,llm),con(iip1,jjp1,llm),nir(iip1,jjp1,llm)
+      real nspec(iip1,jjp1,llm,nqmx),spec(iip1,jjp1,llm)
+
+      REAL v_sd(iip1,jjp1,llm),u_sd(iip1,jjp1,llm)
+      real w_sd(iip1,jjp1,llm),t_sd(iip1,jjp1,llm)
+      real rho_sd(iip1,jjp1,llm)
+      real euv_sd(iip1,jjp1,llm),con_sd(iip1,jjp1,llm)
+      real nir_sd(iip1,jjp1,llm)
+      real nspec_sd(iip1,jjp1,llm,nqmx)
+
+c   ALtitude of the GCM levels (+1 dummy "thermosphere level")
+c   -------------------------
+      REAL zlocal(iip1,jjp1,llm+1) ! altitude above the local surface (m)
+      REAL zareoid(iip1,jjp1,llm+1) ! altitude above the mola areoid (m)
+      real tmean   ! use to integrate hydrostatic equation
+      real sig_therm ! dummy "thermosphere level" as in atmemcd.F
+      real T_therm
+
+c   variables meteo en coordonnee de pression
+c   --------------------------------------------
+      REAL vp(iip1,jjp1,llm),up(iip1,jjp1,llm),wp(iip1,jjp1,llm)
+      REAL tp(iip1,jjp1,llm),rhop(iip1,jjp1,llm)
+      REAL nspecp(iip1,jjp1,llm,nqmx)
+      REAL phip(iip1,jjp1,llm)
+      
+      REAL vp_sd(iip1,jjp1,llm),up_sd(iip1,jjp1,llm)
+      real wp_sd(iip1,jjp1,llm),tp_sd(iip1,jjp1,llm)
+      real rhop_sd(iip1,jjp1,llm),nspecp_sd(iip1,jjp1,llm,nqmx)
+ 
+c     Niveaux de pression (Pa)
+      real pref(llm)
+
+c    Version 32 layers : ************
+      data pref/
+     &1000.,884., 783. , 610., 475, 370, 288, 224, 174, 140.,
+     &115 , 80.6481, 48.0445, 26.6881, 14.1462, 7.29102, 3.70004,
+     &1.86241, 0.933516, 0.466924, 0.233296, 0.116503, 5.81631E-02,
+     & 2.90335E-02,1.44919E-02, 7.23328E-03, 3.61027E-03, 1.80193E-03,
+     & 8.99364E-04,4.48881E-04, 2.15769E-04, 1.3E-04/
+
+c    Version 50 layers : ************
+c      data pref/
+c     &1000.,884., 783. , 610., 475, 370, 288, 224, 174, 140.,
+c     &115 , 80.6481, 48.0445, 26.6881, 14.1462, 7.29102, 3.70004,
+c     &1.86241, 0.933516, 0.466924, 0.233296, 0.116503, 5.81631E-02,
+c     & 2.90335E-02,1.44919E-02, 7.23328E-03, 3.61027E-03, 1.80193E-03,
+c     & 8.99364E-04,4.48881E-04, 2.15769E-04, 1.3E-04,
+c     & 7.23328e-05, 3.61027e-05, 1.80193e-05, 8.99364e-06,
+c     & 4.48881e-06, 2.15769e-06, 1.3e-06,
+c     & 7.23328e-07, 3.61027e-07, 1.80193e-07, 8.99364e-08,
+c     & 4.48881e-08, 2.15769e-08, 1.3e-08,
+c     & 7.23328e-09, 3.61027e-09, 1.80193e-09, 8.99364e-10/
+
+c      data pref/
+c     &1000.,884., 783. , 610., 475, 370, 288, 224, 174, 140.,
+c     &115 , 80.6481, 48.0445, 26.6881, 14.1462, 7.29102, 3.70004,
+c     &1.86241, 0.933516, 0.466924, 0.233296, 0.116503, 5.81631E-02,
+c     & 2.90335E-02,1.44919E-02 / 
+c       data pref/
+c     & 101.4369,94.4369,87.4369,80.4369,73.4369,66.4369,59.4369,52.4369,
+c     & 45.4369,38.4369,31.5527,25.0626,18.9666,13.5138,8.97780,
+c     & 5.54010,3.19040,1.73630,0.907000,0.460400,0.228200,0.109700,
+c     & 0.0500,0.0200,0.0050/
+c   variables meteo en coordonnee de zareoid
+c   --------------------------------------------
+      REAL va(iip1,jjp1,llm),ua(iip1,jjp1,llm),wa(iip1,jjp1,llm)
+      REAL ta(iip1,jjp1,llm),rhoa(iip1,jjp1,llm),ra(iip1,jjp1,llm)
+      real euva(iip1,jjp1,llm),cona(iip1,jjp1,llm),nira(iip1,jjp1,llm)
+      real nspeca(iip1,jjp1,llm,nqmx)
+
+      REAL va_sd(iip1,jjp1,llm),ua_sd(iip1,jjp1,llm)
+      real wa_sd(iip1,jjp1,llm),ta_sd(iip1,jjp1,llm)
+      real rhoa_sd(iip1,jjp1,llm)
+      real euva_sd(iip1,jjp1,llm),cona_sd(iip1,jjp1,llm)
+      real nira_sd(iip1,jjp1,llm)
+      real nspeca_sd(iip1,jjp1,llm,nqmx)
+
+      REAL vij(llm),uij(llm),zaij(llm),wij(llm),rij(llm)
+      REAL tij(llm),rhoij(llm+1),sigij(llm)
+      real euvij(llm),conij(llm),nirij(llm)
+      real nspecij(llm+1,nqmx)
+
+      REAL vij_sd(llm),uij_sd(llm)
+      real wij_sd(llm),tij_sd(llm),rhoij_sd(llm+1)
+      real euvij_sd(llm),conij_sd(llm),nirij_sd(llm)
+      real nspecij_sd(llm+1,nqmx)
+
+c     Niveaux de zareoide (m)
+      real zaref(llm)
+      real p_zaref,p_zaij(llm+1) ! used to interpolate rho
+
+c   Surface data (sometime needed for some analysis):
+c   ------------------------------------------------
+      character relief*3
+      real phis(iip1,jjp1)
+      real alb(iip1,jjp1),ith(iip1,jjp1)
+      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
+      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
+
+
+      real utime
+      real localtime(iip1)
+      common/temporaire/localtime
+
+      INTEGER*4 day0
+      integer nmoy(jjp1,llm),tp1,tp2,pass
+
+      CHARACTER*1 yes,yescomp
+
+      integer iformat
+       
+c   declarations de l'interface avec mywrite:
+c   -----------------------------------------
+
+      CHARACTER file*80
+      CHARACTER nomfich*60
+      CHARACTER nomfile(2)*60,nomfileout(2)*60
+      integer fichsize,fstats
+      CHARACTER fdiag*60
+
+c   externe:
+c   --------
+
+      EXTERNAL iniconst,inigeom,covcont,mywrite
+      EXTERNAL inifilr,exner
+      EXTERNAL solarlong,coordij,moy2
+      EXTERNAL SSUM
+      REAL SSUM
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+
+c   Dust
+c   ----
+
+#include "fxyprim.h"
+
+      character*10  noms(nqmx),varnoms(6)
+      data          noms/"co2","co","o","o1d","o2","o3","h","h2",
+     $                   "oh","ho2","h2o2", "n2", "h2o"/
+      data          varnoms/"T","U","V","W","RHO","Species"/
+
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      unitlec=11
+      itautot=0
+
+
+c     Lecture du fichier a lire
+c     -------------------------
+
+      print*,' ' 
+      PRINT*,'File to process: 1)DIAGFI 2)STATS 3)BOTH'
+      READ(5,'(i)') fichsize
+      if(fichsize.ne.2)then
+        i=1
+        PRINT*,'   enter name of diagfi file (w/o .nc)'
+        READ(5,'(a)') nomfile(i)
+        fdiag=nomfile(i)
+        PRINT*,'   do you want to rename the output file?  
+     &  1) Yes  2) No'
+        READ(5,'(i)') sor
+        if (sor.eq.1) then
+          PRINT*,'   enter label for output file'
+          READ(5,'(a)') nomfileout(i)
+        elseif(sor.eq.2) then
+          nomfileout(i)=nomfile(i)
+        endif
+      endif
+      if(fichsize.ne.1)then
+        i=i+1
+        PRINT*,'   enter name of stats file (w/o .nc)'
+        READ(5,'(a)') nomfile(i)
+        PRINT*,'   do you want to rename the output file?  
+     &  1) Yes  2) No'
+        READ(5,'(i)') sor
+        if (sor.eq.1) then
+          PRINT*,'   enter label for output file'
+          READ(5,'(a)') nomfileout(i)
+        elseif(sor.eq.2) then
+          nomfileout(i)=nomfile(i)
+        endif
+        if(fichsize.eq.2) then
+          PRINT*,'   enter name of diagfi file for controle (w/o .nc)'
+          read(5,'(a)') fdiag
+        endif
+        fstats=1
+      endif
+      if (fichsize.ge.2) fichsize=fichsize-1
+      print*,' '
+      print*,'Output in: 1) netcdf 2) IDL 3) both ?'
+      READ(5,'(i)') sor
+      print*,' '
+      print*,'Coordinates in: 1) pressure 2) Zareoid 3) both  ?'
+      READ(5,'(i)') coor
+      print*,' '
+      print*,'Fields:  T  U  V  W  Rho  Species  All   ?'
+      print*,'Type total number of desired outputs or 6 for All   '
+      READ(5,'(i)') varoutsize
+      if(varoutsize.lt.6) then
+        print*,' '
+        print*,'Fields:  T  U  V  W  Rho  Species '
+        print*,'  #   :  1  2  3  4   5      6'
+        print*,' '
+        do i=1,varoutsize
+          print*,'Type number of variable ',i
+          READ(5,'(i)') varout(i)
+        enddo
+      endif
+      if(varoutsize.eq.6) then
+        do i=1,6
+          varout(i)=i
+        enddo
+      endif
+      do i=1,varoutsize
+        if (varout(i).eq.6) then
+           print*,'Type total number of desired species or 13 for All'
+           READ(5,'(i2)') varspecsize
+           if(varspecsize.ne.13) then
+             print*,' '
+             print*,'Select Species: CO2 CO O O(1D) O2 O3' 
+             print*,'                 1  2  3   4   5  6'
+             print*,'                 H H2 OH HO2 H2O2 N2 H2O'
+             print*,'                 7 8  9  10   11  12 13'
+             do n=1,varspecsize
+               print*,'Type number of species ',i
+               read(5,'(i)') varspec(n)
+             enddo
+           else
+             do n=1,varspecsize
+               varspec(n)=n
+             enddo
+           endif
+         endif
+       enddo
+      if(varoutsize.gt.6) print*,'Value must be <= 6'
+     
+
+! LOOP ON FILES
+! =================================================================
+      do ff=1,fichsize
+ 
+      file=nomfile(ff)  
+      nomfich=nomfile(ff)  
+      file=file(1:lnblnk(file))
+      PRINT*,'file',file
+
+c     Ouverture fichiers :
+c     ------------------
+      write(*,*) "opening "//trim(nomfich)//"..."
+      ierr = NF_OPEN(trim(adjustl(nomfich))//".nc",NF_NOWRITE,nid)
+      if (ierr.NE.NF_NOERR) then
+         write(*,*) 'ERROR: Pb opening file '//nomfich
+         stop ""
+      endif
+
+! Control & lecture on dimensions
+! =================================================================
+      ierr=NF_INQ_DIMID(nid,"latitude",latdim)
+      ierr=NF_INQ_VARID(nid,"latitude",latvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <latitude> is missing'
+      stop ""
+      endif
+      ierr=NF_INQ_DIMLEN(nid,latdim,latlen)
+!  write(*,*) "latlen: ",latlen
+
+      ierr=NF_INQ_DIMID(nid,"longitude",londim)
+      ierr=NF_INQ_VARID(nid,"longitude",lonvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <longitude> is lacking'
+      stop ""
+      endif
+      ierr=NF_INQ_DIMLEN(nid,londim,lonlen)
+!  write(*,*) "lonlen: ",lonlen
+
+      ierr=NF_INQ_DIMID(nid,"altitude",altdim)
+      ierr=NF_INQ_VARID(nid,"altitude",altvar)
+      if (ierr.NE.NF_NOERR) then
+      write(*,*) 'ERROR: Field <altitude> is lacking'
+      stop ""
+      endif
+
+      ierr=NF_INQ_DIMLEN(nid,altdim,altlen)
+!  write(*,*) "altlen: ",altlen
+
+      if (ff.eq.1) then
+        allocate(lat(latlen))
+        allocate(lon(lonlen))
+        allocate(alt(altlen))
+      endif
+
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid,latvar,lat)
+      ierr = NF_GET_VAR_DOUBLE(nid,lonvar,lon)
+      ierr = NF_GET_VAR_DOUBLE(nid,altvar,alt)
+#else
+      ierr = NF_GET_VAR_REAL(nid,latvar,lat)
+      ierr = NF_GET_VAR_REAL(nid,lonvar,lon)
+      ierr = NF_GET_VAR_REAL(nid,altvar,alt)
+#endif
+
+c   Lecture Time :
+
+      ierr= NF_INQ_DIMID (nid,"Time",dimid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'anl_NC: Le champ <Time> est absent'
+          CALL abort
+        ENDIF
+
+      ierr= NF_INQ_DIMLEN (nid,dimid,nbpas)
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, temps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, temps)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'anl_NC: Lecture echouee pour <Time>'
+          CALL abort
+        ENDIF
+        PRINT*,'temps',(temps(itau),itau=1,10)
+! =================================================================
+
+! SETTING OUTPUT FILES
+
+      file=nomfileout(ff)  
+      nomfich=nomfileout(ff)  
+      file=file(1:lnblnk(file))
+
+c    layers in zareoid : ************
+          do l=0,llm-1
+            zaref(l+1)=4500.*l
+            alt(l+1)=zaref(l+1)/1000.
+          enddo 
+
+! =================================================================
+! Output in netcdf
+! =================================================================
+      if (sor.ne.2) then
+
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+ 
+          ierr = NF_CREATE(trim(adjustl(nomfich))//"_P.nc",
+     &                     NF_CLOBBER, nout)
+          if (ierr.NE.NF_NOERR) THEN
+            write(*,*)' Pb d''ouverture du fichier '
+            write(*,*)' ierr = ', ierr
+            STOP
+          ENDIF
+          ierr = NF_PUT_ATT_TEXT(nout, NF_GLOBAL, "title", 24,
+     &                          "Pressure coordinates ")
+          ierr = NF_DEF_DIM(nout,"latitude", size(lat), latdimout)
+          ierr = NF_DEF_DIM(nout,"longitude", size(lon), londimout)
+          ierr = NF_DEF_DIM(nout,"altitude", size(pref), altdimout)
+          ierr = NF_DEF_DIM(nout,"Time", NF_UNLIMITED, timedimout)
+          ierr = NF_ENDDEF(nout)
+
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES 
+
+          ierr = NF_CREATE(trim(adjustl(nomfich))//"_Z.nc",
+     &                     NF_CLOBBER, nout)
+          IF(ierr.NE.NF_NOERR) THEN
+            write(*,*)' Pb d''ouverture du fichier '
+            write(*,*)' ierr = ', ierr
+            STOP
+          ENDIF
+          ierr = NF_PUT_ATT_TEXT(nout, NF_GLOBAL, "title", 24,
+     &                           "zaeroid coordinates")
+          ierr = NF_DEF_DIM(nout,"latitude", size(lat), latdimout)
+          ierr = NF_DEF_DIM(nout,"longitude", size(lon), londimout)
+          ierr = NF_DEF_DIM(nout,"altitude ", size(pref), altdimout)
+          ierr = NF_DEF_DIM(nout,"Time", NF_UNLIMITED, timedimout)
+          ierr = NF_ENDDEF(nout)
+
+        endif
+
+        call def_var(nout,"Time","Time","days since 0000-00-0
+     &  00:00:00",1,(/timedimout/),timevarout,ierr)
+
+        ierr = NF_REDEF (nout)       
+        call def_var(nout,"latitude","latitude","degrees_north",1,
+     &               (/latdimout/),nvarid,ierr)
+
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,lat)
+#else
+        ierr = NF_PUT_VAR_REAL (nout,nvarid,lat)
+#endif
+        ierr = NF_REDEF (nout) 
+        call def_var(nout,"longitude","East longitude","degrees_east",1,
+     &               (/londimout/),nvarid,ierr)
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,lon)
+#else
+        ierr = NF_PUT_VAR_REAL (nout,nvarid,lon)
+#endif
+        ierr = NF_REDEF (nout)
+
+        if(coor.ne.2) then 					! PRESSURE CCOORDINATES
+#ifdef NC_DOUBLE
+          ierr = NF_DEF_VAR (nout,"altitude",NF_DOUBLE,1,
+     &                       (/altdimout/), nvarid)
+#else
+          ierr = NF_DEF_VAR (nout,"altitude",NF_FLOAT,1,
+     &                       (/altdimout/),nvarid)
+#endif
+
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,"long_name",22,"altitude
+     &                            pression")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'units',2,"Pa")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'positive',4,"down")
+          ierr = NF_ENDDEF(nout)
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,pref)
+#else
+          ierr = NF_PUT_VAR_REAL (nout,nvarid,pref)
+#endif
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES 
+
+#ifdef NC_DOUBLE
+          ierr = NF_DEF_VAR (nout,"altitude",NF_DOUBLE,1,
+     &                       (/altdimout/), nvarid)
+#else
+          ierr = NF_DEF_VAR (nout,"altitude",NF_FLOAT,1,
+     &                       (/altdimout/),nvarid)
+#endif
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,"long_name",20,"altitude
+     &                           zaeroid")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'units',2,"km")
+          ierr = NF_PUT_ATT_TEXT (nout,nvarid,'positive',2,"up")
+          ierr = NF_ENDDEF(nout)
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR_DOUBLE (nout,nvarid,alt)
+#else
+          ierr = NF_PUT_VAR_REAL (nout,nvarid,alt)
+#endif
+        endif
+
+      endif !end if netcdf  
+
+! Output in idl
+! =================================================================
+      if (sor.ne.1) then
+
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+          do i=1,varoutsize
+            j=121+i
+            if(varout(i).eq.6) then
+              do iq=1,varspecsize
+                file=trim(nomfileout(ff))//'_P_'
+     &               //trim(noms(iq))//'.dat'  
+                j=121+i+(iq-1)
+                open(j,file=trim(file), status='unknown')
+                write(j,117) noms(iq) 
+                write(j,120) iim,jjp1,llm
+                write(j,119) lon
+                write(j,119) lat
+                write(j,119) pref
+              enddo
+            else
+              file=trim(nomfileout(ff))//'_P_'
+     &            //trim(varnoms(varout(i)))//'.dat'  
+              open(j,file=trim(file), status='unknown')
+              write(j,117) varnoms(varout(i)) 
+              write(j,120) iim,jjp1,llm
+              write(j,119) lon
+              write(j,119) lat
+              write(j,119) pref
+            endif
+          enddo 
+        endif
+
+        if(coor.ne.1) then 					! ZAEROID COORDINATES
+          do i=1,varoutsize
+            j=1221+i
+            if(varout(i).eq.6) then
+              do iq=1,varspecsize
+                file=trim(nomfileout(ff))//'_Z_'
+     &               //trim(noms(iq))//'.dat'  
+                j=1221+i+(iq-1)
+                open(j,file=trim(file), status='unknown')
+                write(j,117) noms(iq)
+                write(j,120) iim,jjp1,llm
+                write(j,119) lon
+                write(j,119) lat
+                write(j,119) alt
+              enddo
+            else
+              file=trim(nomfileout(ff))//'_Z_'
+     &            //trim(varnoms(varout(i)))//'.dat'  
+              open(j,file=trim(file), status='unknown')
+              write(j,117) varnoms(varout(i))
+              write(j,120) iim,jjp1,llm
+              write(j,119) lon
+              write(j,119) lat
+              write(j,119) alt
+            endif
+          enddo
+              
+c              file=trim(nomfileout(ff))
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_EUV.dat',
+c     &               status='unknown')
+c              write(j,117) 'EUV'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_CON.dat',
+c     &               status='unknown')
+c              write(j,117) 'CONDUCTION'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+c              j=j+1
+c              open(j,file=file(1:lnblnk(file))//'_Z_NIR.dat',
+c     &               status='unknown')
+c              write(j,117) 'NIR'
+c              write(j,120) iim,jjp1,llm
+c              write(j,119) lon
+c              write(j,119) lat
+c              write(j,119) alt
+        endif
+
+      endif
+120    format(3i3)
+119    format(12(e10.4,1x))
+118    format(2i3)
+117    format(6(a7))
+116    format(13(a6))
+! =================================================================
+ 
+
+800   continue ! LOOP SUR LES FICHIERS
+
+
+! =================================================================
+! INITIALIZATION OF PARAMETERS
+! =================================================================
+
+      rad=3397200.              ! rayon de mars (m)  ~3397200 m
+      daysec=88775.             ! duree du sol (s)  ~88775 s
+      omeg=4.*asin(1.)/(daysec) ! vitesse de rotation (rad.s-1)
+      g=3.72                    ! gravite (m.s-2) ~3.72
+      mugaz=43.49               ! Masse molaire de l'atm (g.mol-1) ~43.49
+      kappa=.256793             ! = r/cp  ~0.256793
+      r = 191.18213
+      pi=2.*asin(1.)
+      ecritphy =1
+      iphysiq=1
+      day_ini=0.
+      day_step=1
+
+      CALL readhead_NC(trim(adjustl(fdiag))//".nc",day0,phis,R)
+      WRITE (*,*) 'day0 = ' , day0
+
+      CALL iniconst
+      CALL inigeom
+      CALL inifilr
+
+c  Dummy "thermosphere level" as in atmemcd (extrapol above top GCM level)
+      sig_therm=bps(llm)*exp(-20./7.)
+      T_therm = 200.  ! temperature (K) of the "thermosphere level"
+
+   
+c     If needed : getting topography, albedo, thermal inertia...
+c     -------------------------------------------------------
+c     "phis" is the surface geopotential = topography (m) * g 
+       relief='mola'    ! Topography MOLA par defaut
+
+c       CALL datareadnc(relief,phis,alb,ith,zmeaS,zstdS,zsigS,zgamS,
+c     .          ztheS)
+
+
+! =================================================================
+! LOOP IN TIME
+! =================================================================
+
+      DO itau=1,nbpas
+
+! FILE READING
+! =================================================================
+        print*,'Timestep = ',itau,'/',nbpas
+
+c        call lect_var(nid,'tsurf',3,ierr,itau,	tsurf)
+        call lect_var(nid,'ps',3,ierr,itau,		ps)
+
+        call lect_var(nid,'temp',4,ierr,itau,	t)
+        call lect_var(nid,'u',4,ierr,itau,		u)
+        call lect_var(nid,'v',4,ierr,itau,		v)
+c        call lect_var(nid,'w',4,ierr,itau,		w)
+c        call lect_var(nid,'rho',4,ierr,itau,	rho)
+        do l=1,llm
+          do j=1,jjp1
+            do i=1,iip1
+              Rnew(i,j,l)=8.314/mugaz*1.e3 
+! A enregistrer lors du run pour pouvoir le lire avec la ligne dessous
+            enddo
+          enddo
+        enddo
+c        call lect_var(nid,'r',4,ierr,itau,		Rnew)
+c        call lect_var(nid,'euv',4,ierr,itau,	euv)
+c        call lect_var(nid,'cond',4,ierr,itau,	con)
+c        call lect_var(nid,'nir',4,ierr,itau,	nir)
+        do n=1,varspecsize
+          i=varspec(n)
+        call lect_var(nid,'n_'//trim(noms(i)),4,ierr,itau,	spec)
+        do l=1,llm
+          do j=1,jjp1
+            do i=1,iip1
+              nspec(i,j,l,n)=spec(i,j,l)
+            enddo
+          enddo
+        enddo
+        enddo
+
+        if(fstats*ff-fichsize .eq. 0) then
+          call lect_var(nid,'temp_sd',4,ierr,itau,	t_sd)
+          call lect_var(nid,'u_sd',4,ierr,itau,		u_sd)
+          call lect_var(nid,'v_sd',4,ierr,itau,		v_sd)
+c          call lect_var(nid,'w_sd',4,ierr,itau,		w_sd)
+c          call lect_var(nid,'rho_sd',4,ierr,itau,	rho_sd)
+          do n=1,varspecsize
+            i=varspec(n)
+            call lect_var(nid,'n_'//trim(noms(i))//'_sd',4,ierr,
+     &                    itau,	spec)
+            do l=1,llm
+              do j=1,jjp1
+                do i=1,iip1
+                  nspec_sd(i,j,l,n)=spec(i,j,l)
+                enddo
+              enddo
+            enddo
+          enddo
+        endif
+! =================================================================
+
+! COMPUTING ALTITUDE OF GCM LEVELS IN GCM GRID
+! =================================================================
+c      zlocal 	! altitude above the local surface (m)
+c      zareoid 	! altitude above the mola areoid (m)
+
+        do j=1,jjp1
+          do i=1,iip1
+            sigij(1)=aps(1)/ps(i,j)+bps(1)
+            zlocal(i,j,1)=-log(sigij(1))* Rnew(i,j,1)*t(i,j,1)/g
+c            phis(i,j)=0.0
+c            phi(i,j,1)=phis(i,j)
+c            rho(i,j,1)=sigij(1)*ps(i,j)/(Rnew(i,j,1)*t(i,j,1))
+            zareoid(i,j,1) = zlocal(i,j,1) + phis(i,j)/g
+            do l=2,llm
+              sigij(l)=aps(l)/ps(i,j)+bps(l)
+              tmean=t(i,j,l)
+              if(t(i,j,l).ne.t(i,j,l-1))
+     &          tmean=(t(i,j,l)-t(i,j,l-1))/log(t(i,j,l)/t(i,j,l-1))
+              zlocal(i,j,l)=zlocal(i,j,l-1) 
+     &                -log(sigij(l)/sigij(l-1))*Rnew(i,j,l-1)*tmean/g
+              zareoid(i,j,l) = zlocal(i,j,l) + phis(i,j)/g
+c              rho(i,j,l)=sigij(l)*ps(i,j)/(Rnew(i,j,l)*t(i,j,l))
+              phi(i,j,l)=zareoid(i,j,l)*g
+            enddo
+  
+c           Altitude of the dummy thermosphere level (as in atmemcd)   
+c           ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+            tmean=(T_therm-t(i,j,llm))/log(T_therm/t(i,j,llm))
+            zlocal(i,j,llm+1)=zlocal(i,j,llm) 
+     &                  -log(sig_therm/sigij(llm))*Rnew(i,j,llm)*tmean/g
+            zareoid(i,j,llm+1) = zlocal(i,j,llm+1) + phis(i,j)/g
+
+          enddo
+        enddo
+
+c            do l=1,llm
+c        print*,zareoid(32,24,l),zlocal(32,24,l),zaref(l)
+c        print*,zareoid(32,24,l),zaref(l)
+c            enddo
+
+c Local time
+c ----------
+c universal time (in stats oe MCD files)
+        utime = (itau-1)*2.
+
+c local time (in stats file)
+        DO i = 1,iim
+          localtime(i)=utime + 12.*rlonv(i)/pi
+          if(localtime(i).gt.24) localtime(i)=localtime(i)-24.
+          if(localtime(i).lt.0) localtime(i)=localtime(i)+24.
+        ENDDO
+
+c c Passage en niveaux de pression
+c ------------------------------
+        if(coor.ne.2) then 					! PRESSURE COORDINATES
+          call xsig2p (ps,T,pref,llm,Tp)
+          call xsig2p (ps,u,pref,llm,up)
+          call xsig2p (ps,v,pref,llm,vp)
+          call xsig2p (ps,w,pref,llm,wp)
+          call xsig2p (ps,rho,pref,llm,rhop)
+          do iq=1,varspecsize
+            call xsig2p (ps,nspec(1,1,1,iq),pref,llm,nspecp(1,1,1,iq))
+          enddo
+           if(fstats*ff-fichsize .eq. 0) then
+             call xsig2p (ps,u_sd,pref,llm,up_sd)
+             call xsig2p (ps,v_sd,pref,llm,vp_sd)
+             call xsig2p(ps,t_sd,pref,llm,Tp_sd)
+             call xsig2p (ps,w_sd,pref,llm,wp_sd)
+             call xsig2p (ps,rho_sd,pref,llm,rhop_sd)
+             do iq=1,varspecsize
+               call xsig2p (ps,nspec_sd(1,1,1,iq),pref,llm,
+     $                      nspecp_sd(1,1,1,iq))
+             enddo
+           endif
+         endif
+
+c c Passage en niveaux de zareoid
+c ------------------------------
+        if(coor.ne.1) then 					! ZAEROID COORDINATES
+        do j=1,jjp1
+          do i=1,iip1
+            do l=1,llm
+              Tij(l)=T(i,j,l)
+              uij(l)=u(i,j,l)
+              vij(l)=v(i,j,l)
+              wij(l)=w(i,j,l)
+              rhoij(l)=rho(i,j,l)
+              do iq=1,varspecsize
+                nspecij(l,iq)=nspec(i,j,l,iq)
+                if(l.eq.llm) nspecij(l+1,iq)=nspecij(l,iq)*1.e-3
+              enddo
+c              euvij(l)=euv(i,j,l)
+c              conij(l)=con(i,j,l)
+c              nirij(l)=nir(i,j,l)
+              zaij(l)=zareoid(i,j,l)
+              p_zaij(l)=exp(-zareoid(i,j,l)/1.e4) ! used to interpolate rho
+              if(fstats*ff-fichsize .eq. 0) then
+                Tij_sd(l)=T_sd(i,j,l)
+                uij_sd(l)=u_sd(i,j,l)
+                vij_sd(l)=v_sd(i,j,l)
+                wij_sd(l)=w_sd(i,j,l)
+                rhoij_sd(l)=rho_sd(i,j,l)
+                do iq=1,varspecsize
+                  nspecij_sd(l,iq)=nspec_sd(i,j,l,iq)
+                  if(l.eq.llm) nspecij_sd(l+1,iq)=nspecij_sd(l,iq)*1.e-3
+                enddo
+              endif
+            enddo
+            p_zaij(l+1)=exp(-zareoid(i,j,l+1)/1.e4) 
+c            rhoij(l+1)=sig_therm*ps(i,j)/(R*T_therm)!in dummy thermosphere
+            rhoij(l+1)=rhoij(llm)*1.e-3
+            rhoij_sd(l+1)=rhoij_sd(llm)*1.e-3
+
+            do l=1,llm
+              call interpolf(zaref(l),y,zaij,Tij,llm)
+              Ta(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,uij,llm)
+              ua(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,vij,llm)
+              va(i,j,l)=y
+              call interpolf(zaref(l),y,zaij,wij,llm)
+              wa(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,euvij,llm)
+c              euva(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,conij,llm)
+c              cona(i,j,l)=y
+c              call interpolf(zaref(l),y,zaij,nirij,llm)
+c              nira(i,j,l)=y
+
+              p_zaref=exp(-zaref(l)/1.e4)
+              call interpolf(p_zaref,y,p_zaij,rhoij,llm+1)
+              rhoa(i,j,l)=y
+               
+              do iq=1,varspecsize
+                call interpolf(p_zaref,y,p_zaij,nspecij(1,iq),llm+1)
+c                call interpolf(zaref(l),y,zaij,nspecij(1,iq),llm)
+                nspeca(i,j,l,iq)=y
+              enddo
+
+              if(fstats*ff-fichsize .eq. 0) then
+                call interpolf(zaref(l),y,zaij,Tij_sd,llm)
+                Ta_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,uij_sd,llm)
+                ua_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,vij_sd,llm)
+                va_sd(i,j,l)=y
+                call interpolf(zaref(l),y,zaij,wij_sd,llm)
+                wa_sd(i,j,l)=y
+                call interpolf(p_zaref,y,p_zaij,rhoij_sd,llm+1)
+                rhoa_sd(i,j,l)=y
+                do iq=1,varspecsize
+                  call interpolf(p_zaref,y,p_zaij,nspecij_sd(1,iq),
+     &                           llm+1)
+c                  call interpolf(zaref(l),y,zaij,nspecij_sd(1,iq),llm)
+                  nspeca_sd(i,j,l,iq)=y
+                enddo
+              endif
+
+            enddo
+          enddo
+        enddo
+
+c            do l=1,llm
+c        print*,T(32,24,l),Ta(32,24,l)
+c        print*,nspec(32,24,l,1),nspeca(32,24,l,1)
+c            enddo
+
+        endif
+ 
+c Output at each time-step, in netcdf format
+! =================================================================
+        if (sor .ne. 2) then
+
+          ierr= NF_INQ_VARID(nout,"Time",nvarid)
+#ifdef NC_DOUBLE
+          ierr= NF_PUT_VARA_DOUBLE(nout,nvarid,itau,1,temps(itau))
+#else
+          ierr= NF_PUT_VARA_REAL(nout,nvarid,itau,1,temps(itau))
+#endif
+          if (ierr.ne.NF_NOERR) then
+            write(*,*) "time problem ",NF_STRERROR(ierr)
+            stop
+          endif
+
+          if (varoutsize.eq.6) n=1
+          if (varoutsize.ne.6) n=varoutsize
+          do i=1,n
+            if(varout(i).eq.1 .or. varoutsize.eq.6) then
+             if(coor.ne.1) 
+     &          call put_var(nout,'temp','temp','K',4,ierr,itau,Ta)
+             if(coor.ne.2) 
+     &          call put_var(nout,'temp','temp','K',4,ierr,itau,Tp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'temp_sd','temp_sd','K',
+     &                                      4,ierr,itau,Ta_sd)
+                if(coor.ne.2) call put_var(nout,'temp_sd','temp_sd','K',
+     &                                      4,ierr,itau,Tp_sd)
+              endif
+            endif
+            if(varout(i).eq.2 .or. varoutsize.eq.6)  then
+              if(coor.ne.1) 
+     &          call put_var(nout,'u','u','m s-1',4,ierr,itau,ua)
+              if(coor.ne.2) 
+     &          call put_var(nout,'u','u','m s-1',4,ierr,itau,up)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'u_sd','u_sd','m s-1',
+     &                                      4,ierr,itau,ua_sd)
+                if(coor.ne.2) call put_var(nout,'u_sd','u_sd','m s-1',
+     &                                      4,ierr,itau,up_sd)
+              endif
+            endif
+            if(varout(i).eq.3 .or. varoutsize.eq.6) then
+              if(coor.ne.1) 
+     &          call put_var(nout,'v','v','m s-1',4,ierr,itau,va)
+              if(coor.ne.2) 
+     &          call put_var(nout,'v','v','m s-1',4,ierr,itau,vp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'v_sd','v_sd','m s-1',
+     &                                      4,ierr,itau,va_sd)
+                if(coor.ne.2) call put_var(nout,'v_sd','v_sd','m s-1',
+     &                                      4,ierr,itau,vp_sd)
+              endif
+            endif
+            if(varout(i).eq.4 .or. varoutsize.eq.6) then
+              if(coor.ne.1) 
+     &          call put_var(nout,'w','w','m s-1',4,ierr,itau,wa)
+              if(coor.ne.2) 
+     &          call put_var(nout,'w','w','m s-1',4,ierr,itau,wp)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'w_sd','w_sd','m s-1',
+     &                                      4,ierr,itau,wa_sd)
+                if(coor.ne.2) call put_var(nout,'w_sd','w_sd','m s-1',
+     &                                      4,ierr,itau,wp_sd)
+              endif
+            endif
+            if(varout(i).eq.5 .or. varoutsize.eq.6)  then
+              if(coor.ne.1) call put_var(nout,'rho','rho','',4,ierr,
+     &                                    itau,rhoa)
+              if(coor.ne.2) call put_var(nout,'rho','rho','',4,ierr,
+     &                                    itau,rhop)
+              if(fstats*ff-fichsize.eq.0) then
+                if(coor.ne.1) call put_var(nout,'rho_sd','rho_sd','',
+     &                                      4,ierr,itau,rhoa_sd)
+                if(coor.ne.2) call put_var(nout,'rho_sd','rho_sd','',
+     &                                      4,ierr,itau,rhop_sd)
+              endif
+            endif
+            if(varout(i).eq.6 .or. varoutsize.eq.6) then
+              do iq=1,varspecsize
+                j=varspec(iq)
+                if(coor.ne.1) call put_var(nout,'n_'//trim(noms(j)),
+     &       'n_'//trim(noms(j)),'cm-3',4,ierr,itau,nspeca(1,1,1,iq))
+                if(coor.ne.2) call put_var(nout,'n_'//trim(noms(j)),
+     &         'n_'//trim(noms(j)),'cm-3',4,ierr,itau,nspecp(1,1,1,iq))
+                if(fstats*ff-fichsize.eq.0) then
+                  if(coor.ne.1) call put_var(nout,
+     &                        'n_'//trim(noms(j))//'_sd',
+     &                        'n_'//trim(noms(j))//'_sd','cm-3',4,ierr,
+     &                           itau,nspeca_sd(1,1,1,iq))
+                  if(coor.ne.2) call put_var(nout,
+     &                        'n_'//trim(noms(j))//'_sd',
+     &                        'n_'//trim(noms(j))//'_sd','cm-3',4,ierr,
+     &                           itau,nspecp_sd(1,1,1,iq))
+                endif
+              enddo
+            endif     
+          enddo
+        endif !endif writing data on Netcdf file 
+
+c Output at each time-step, ASCII file for IDL
+! =================================================================
+c In pressure and zareoid coordinates:
+
+      if (sor .ne. 1) then
+       do n=1,varoutsize
+         if(varout(n).eq.1) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((Tp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((Ta(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.2) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((up(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1)then
+               k=1221+n
+               write(k,124) ((ua(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif 
+         if(varout(n).eq.3) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(k,124) ((vp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((va(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.4) then
+           do l=1,llm
+             if(coor.ne.2) then
+               k=121+n
+               write(122,124) ((wp(i,j,l),i=1,iim),j=1,jjp1)
+             elseif(coor.ne.1) then
+               k=1221+n
+               write(k,124) ((wa(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.5) then
+           do l=1,llm
+            if(coor.ne.2) then
+              k=121+n
+              write(k,124) ((rhop(i,j,l),i=1,iim),j=1,jjp1)
+            elseif(coor.ne.1) then
+               k=1221+n
+              write(k,124) ((rhoa(i,j,l),i=1,iim),j=1,jjp1)
+             endif
+           enddo
+         endif
+         if(varout(n).eq.6) then
+           do iq=1,varspecsize
+             do l=1,llm
+               if(coor.ne.1) then
+                 k=1221+n+(iq-1)
+                 write(k,124) ((nspeca(i,j,l,iq),i=1,iim),j=1,jjp1)
+               endif
+             enddo
+           enddo
+         endif     
+       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((euva(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((cona(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+c       k=k+1
+c       do l=1,llm
+c         if(coor.ne.1)write(k,124) ((nira(i,j,l),i=1,iim),j=1,jjp1)
+c       enddo
+      endif
+124   format(12(e10.4,1x))
+
+
+       ENDDO		!LOOP in TIME
+! =================================================================
+
+ 900   continue
+
+
+c  ECRITURE FINALE si besoin
+c  *************************
+      ierr= NF_CLOSE(nid)
+      ierr=NF_CLOSE(nout)
+      close (33)
+      close (122)
+      close (1222)
+       
+      ENDDO		!LOOP in FILES
+! =================================================================
+
+9999  PRINT*,'Fin '
+1000  format(a5,3x,i4,i3,x,a39)
+7777  FORMAT ('latitude/longitude',4f7.1)
+
+      END
+
+c*******************************************************
+
+      subroutine  xsig2p (ps,qsig,pref,npref,qp)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Francois Forget    Avril 1996
+c
+c Cette subroutine calcule les champs interpole en niveaux de pression
+c different niveaux de pression pref
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c  ARGUMENTS
+c  ---------
+
+c Inputs:
+      
+      REAL qsig(iip1,jjp1,llm)
+      REAL ps(iip1,jjp1)
+      integer npref
+      real pref(npref)
+
+c outputs
+      REAL qp(iip1,jjp1,npref)
+
+
+c Variables du modele
+c -------------------
+
+      REAL lnp(llm)  , q(llm)
+      REAL x,y
+      INTEGER i,j,l ,n
+
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+ 
+#include "fxyprim.h"
+c**********************************************************************
+         if (firstcall) then
+           write(*,*) 'kappa = ', kappa
+           write(*,*) 'cpp = ', cpp
+           firstcall = .false.
+         end if
+
+        DO j=1,jjp1
+          DO i=1,iip1
+            do l=1,llm
+              lnp(l) = -log(aps(l)+bps(l)*ps(i,j))
+              q(l) = qsig(i,j,l)
+            end do
+            do n =1,npref
+              if ( (pref(n).le.ps(i,j)) .and.
+     &          (pref(n).ge.(ps(i,j)*bps(llm)+aps(llm))) ) then
+                    x = -log(pref(n))
+                    call interpolf(x,y,lnp,q,llm)
+                    qp(i,j,n) = y
+              else
+                    qp(i,j,n) = 1E+20 
+              end if
+            end do
+          ENDDO
+        ENDDO
+
+      return
+      end 
+
+      subroutine  missing_value(nout,nvarid,valid_range,missing)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+      include "netcdf.inc"
+
+      INTEGER nout,nvarid,ierr
+      REAL missing
+      REAL valid_range(2)
+c
+c  ARGUMENTS
+c  ---------
+
+c Inputs:
+      
+             ierr= NF_PUT_ATT_REAL(nout,nvarid,'valid_range',
+     $  NF_FLOAT,2,valid_range)
+        IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'anl_NC: valid_range attribution failed'
+            WRITE(*,*) 'NF_NOERR', NF_NOERR
+            CALL abort
+        ENDIF
+
+#ifdef NC_DOUBLE
+             ierr= NF_PUT_ATT_DOUBLE(nout,nvarid,'missing_value',
+     $  NF_DOUBLE,1,missing)
+#else
+              ierr= NF_PUT_ATT_REAL(nout,nvarid,'missing_value',
+     $  NF_FLOAT,1,missing)
+
+#endif
+
+        IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'anl_NC: missing value attribution failed'
+            WRITE(*,*) 'NF_NOERR', NF_NOERR
+            CALL abort
+        ENDIF
+      return
+      end
+**********************************************************
+      subroutine lect_var(nid,name,nbdim,ierr,itau,
+     $ var)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c inputs
+      character (len=*) :: name
+      INTEGER nid,nbdim,nvarid,ierr,itau
+      integer, dimension(nbdim) :: edges,corner
+c output var
+      integer, dimension(nbdim) :: var
+c  ---------
+        if (nbdim.eq.4) then
+         corner=(/1,1,1,itau/)
+         edges=(/iip1,jjp1,llm,1/)
+        endif
+
+        if (nbdim.eq.3) then
+            corner=(/1,1,itau/)
+            edges=(/iip1,jjp1,1/)
+        endif
+
+
+          ierr = NF_INQ_VARID (nid,adjustl(name), nvarid)
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid, nvarid,corner,edges, var)
+#else
+          ierr = NF_GET_VARA_REAL(nid, nvarid,corner,edges, var)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+            write(*,*) 'anl_NC: reading failed for ', name
+            CALL abort
+          ENDIF
+
+      return
+      end
+
+
+      subroutine put_var(nout,name,title,units,nbdim,ierr,itau,
+     $ var)
+      IMPLICIT NONE
+c=======================================================================
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+#include "netcdf.inc"
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+
+      character (len=*) :: title,units,name
+      INTEGER nout,nbdim,nvarid,ierr,itau
+      integer, dimension(nbdim) :: edges,corner,id,var
+      REAL valid_range(2)
+      DATA valid_range /0., 300.0/
+c  ---------
+        if (nbdim.eq.4) then
+         ierr= NF_INQ_DIMID(nout,"longitude",id(1))
+         ierr= NF_INQ_DIMID(nout,"latitude",id(2))
+         ierr= NF_INQ_DIMID(nout,"altitude",id(3))
+         ierr= NF_INQ_DIMID(nout,"Time",id(4))
+         corner=(/1,1,1,itau/)
+         edges=(/iip1,jjp1,llm,1/)
+        endif
+
+        if (nbdim.eq.3) then
+             ierr= NF_INQ_DIMID(nout,"longitude",id(1))
+             ierr= NF_INQ_DIMID(nout,"latitude",id(2))
+             ierr= NF_INQ_DIMID(nout,"Time",id(3))
+            corner=(/1,1,itau/)
+            edges=(/iip1,jjp1,1/)
+        endif
+
+
+        ierr = NF_INQ_VARID (nout,adjustl(name), nvarid)
+          if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+! Creation de la variable si elle n'existait pas
+             write (*,*) "====================="
+             write (*,*) "creation de  ",name
+         call def_var(nout,adjustl(title),adjustl(name),adjustl(units),
+     $   nbdim,id,nvarid,ierr)
+          if (name.eq.'temp') then
+             ierr = NF_REDEF (nout)
+             call missing_value(nout,nvarid,valid_range,1E+20)
+             ierr = NF_ENDDEF(nout)
+          endif
+          endif
+#ifdef NC_DOUBLE
+        ierr = NF_PUT_VARA_DOUBLE(nout,nvarid,corner,edges,var)
+#else
+        ierr = NF_PUT_VARA_REAL(nout,nvarid,corner,edges,var)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+            write(*,*) 'anl_NC: writing failed for ',name
+            CALL abort
+        ENDIF
+
+                
+      return
+      end
+
+
+      Subroutine interpolf(x,y,xd,yd,nd)
+
+c******************************************************
+c   SUBROUTINE   (interpol)
+c interpolation, give y = f(x) with array xd,yd known, size nd
+
+c  Version with CONSTANT values oustide limits
+c**********************************************************
+
+
+c Variable declaration
+c --------------------
+c  Arguments :
+      real x,y
+      real xd(*),yd(*)
+      integer nd
+c  internal
+      integer i,j
+      real y_undefined
+
+c run
+c ---
+c      y_undefined=-999.999
+      y_undefined=1.e20
+
+      y=0.
+      if ((x.le.xd(1)).and.(x.le.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = y_undefined ! yd(1)
+        if (xd(1).ge.xd(nd)) y = y_undefined ! yd(nd)
+      else if ((x.ge.xd(1)).and.(x.ge.xd(nd))) then
+        if (xd(1).lt.xd(nd)) y = y_undefined ! yd(nd)
+        if (xd(1).ge.xd(nd)) y = y_undefined ! yd(1)
+c       y = yd(nd)
+      else
+        do i=1,nd-1
+         if ( ( (x.ge.xd(i)).and.(x.lt.xd(i+1)) )
+     &     .or. ( (x.le.xd(i)).and.(x.gt.xd(i+1)) ) ) then
+           y=yd(i)+(x-xd(i))*(yd(i+1)-yd(i))/(xd(i+1)-xd(i))
+           goto 99
+         end if
+        end do
+      end if
+
+c     write (*,*)' x , y' , x,y
+c     do i=1,nd
+c       write (*,*)' i, xd , yd' , xd(i),yd(i)
+c     end do
+c     stop
+
+ 99   continue
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anldoppler2.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anldoppler2.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/anldoppler2.F	(revision 57)
@@ -0,0 +1,380 @@
+      PROGRAM anldoppler2
+      IMPLICIT NONE
+c======================================================================
+c
+c
+c Programme pour analyser vent a heure locale fixee
+c a partir d'un fichier Netcdf de la MCD
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+
+
+      INTEGER point
+      PARAMETER(point=11)     		! nbre de points d''observation
+      real olon(point),olat(point)	! Coordonnees des points observes
+      INTEGER iraie                	! pour le choix de la raie du CO
+
+c--------------------------------------------------------
+c coordonees lon/lat des points observes
+c--------------------------------------------------------
+
+c     ANNEE 2001
+
+      DATA olon/0,-30,30,0,-90,90,-75,75,0,-70,70/
+      DATA olat/-1,0,0,40,0,0,40,40,90,-40,40/
+
+c     ANNEE 1999
+
+c      DATA olon/0,0,-30,30,-85,85,0,-90,90,0,-65,65,0/
+c      DATA olat/18,-10,0,0,0,0,55,40,40,90,-40,-40,-70/
+
+c     ANNEE 1997
+
+c      DATA olon/0,-85,85,0,0/
+c      DATA olat/24,0,0,90,-70/
+
+c     ANNEE 1992
+
+c      DATA olon/0,-85,85,0,0,-75,75,-90,90,0,0/
+c      DATA olat/8,0,0,-40,40,-40,-40,40,40,90,-90/
+
+c     ANNEE 1990
+
+c      DATA olon/0,-90,90,0,0/
+c      DATA olat/-1,0,0,70,-90/
+
+c     ANNEE 1988
+
+c      DATA olon/0,-90,90,0,0,0,-35,35,0,0,-45,45,-60,60/
+c      DATA olat/-21,0,0,-90,60,0,0,0,-35,25,-35,-35,25,25/
+
+c----------------------------------------------------------
+
+      INTEGER mcdreadnc
+      external mcdreadnc
+      INTEGER itau,nbpas,nbpasmx
+      PARAMETER(nbpasmx=1000000)
+      REAL temps(nbpasmx)
+      INTEGER unitlec
+      INTEGER i,j,l,itautot
+
+c   Declarations DRS:
+c   -----------------
+      INTEGER ierr, dimtype
+      CHARACTER*120 dimsou, dimnam*16, dimtit*80
+      CHARACTER*40 dimunit
+      CHARACTER*100  varname
+
+c   variables meteo dans la grille verticale GCM
+c   --------------------------------------------
+      REAL v(iip1,jjp1,llm),u(iip1,jjp1,llm)
+      REAL t(iip1,jjp1,llm)
+      REAL ps(iip1,jjp1) , tsurf(iip1,jjp1)
+
+c   variables meteo en coordonnee de pression
+c   --------------------------------------------
+      REAL vp(iip1,jjp1,llm),up(iip1,jjp1,llm)
+      REAL tp(iip1,jjp1,llm)
+
+c     Niveaux de pression (Pa)
+      real pref(llm)
+
+c     version 25 couches
+
+c      data pref/1291.37,1005.720,783.255,600.,475.069,350.,
+c     &          288.144,174.768,106.002,64.2935,38.9960,
+c     &          23.6523,14.3458,8.70000,5.28000,3.20000,
+c     &          1.94000,1.18000,0.714000,0.433000,0.263000,
+c     &          0.118000,0.0614000,0.0333000,0.0163000/
+
+c     version 32 couches
+
+      data pref/1291.37,1005.720,783.255,600.,475.069,350.,
+     &          288.144,174.768,106.002,64.2935,38.9960,
+     &          23.6523,14.3458,8.70000,5.28000,3.20000,
+     &          1.94000,1.18000,0.714000,0.433000,0.263000,
+     &          0.118000,0.0614000,0.0333000,0.0163000, 
+     &          8.e-3,4.e-3,2.e-3,1.e-3,5.e-4,2.e-4,1.e-4/
+
+c   Local:
+c   ------
+      REAL phis(iip1,jjp1)
+      real utime,latst,lonst,tamp,hlst
+      real localtime(iip1),heure(iip1)
+      common/temporaire/localtime
+
+      INTEGER*4 day0
+c      integer nmoy(jjp1,llm),tp1,tp2,pass
+	
+
+      CHARACTER*1 yes
+
+      LOGICAL ldrs
+      integer iformat,nid
+       
+c   declarations de l'interface avec mywrite:
+c   -----------------------------------------
+
+      CHARACTER file*80
+      CHARACTER nomfich*60
+
+c   externe:
+c   --------
+
+      EXTERNAL iniconst,inigeom,covcont,mywrite
+      EXTERNAL inifilr,exner
+      EXTERNAL solarlong,coordij,moy2
+      EXTERNAL SSUM
+      REAL SSUM
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+      logical icdf,idrs
+
+c   Dust
+c   ----
+
+#include "fxyprim.h"
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      ldrs=.true.
+      unitlec=11
+      itautot=0
+      idrs=.false.
+      icdf=.false.
+
+c     Lecture du fichier a lire
+c     -------------------------
+
+      PRINT*,'entrer le nom du fichier NetCDF de la MCD'
+      READ(5,'(a)') nomfich
+      file=nomfich(1:lnblnk(nomfich))
+      PRINT*,'file',file
+
+
+c     Lecture des autres parametres du programme
+c     ------------------------------------------
+
+      write(*,*) 'Raie a simuler ? '
+      write(*,*)'[1]12CO(2-1) [2]:13CO(2-1) ',
+     &     ' [3]:12CO(1-0) [4]13CO(1-0) [5]H2O(183)'  
+      read(*,*) iraie
+
+      write(*,*) 'heure local du point subterrestre ? '
+      read(*,*) hlst
+
+      write(*,*) 'latitude du point subterrestre ? '
+      read(*,*) latst
+
+c---------------------------------------------------------
+c   Lecture des fichiers stats , diagfi ou histmoy
+c---------------------------------------------------------
+
+800   continue ! LOOP SUR LES FICHIERS
+
+c     Ouverture fichiers :
+c     ------------------
+
+c        Ouverture fichier NetCDF
+            ierr = NF_OPEN (file(1:lnblnk(file))//'.nc', NF_NOWRITE,nid)
+            IF (ierr.NE.NF_NOERR) THEN
+              write(6,*)' Pb d''ouverture du fichier ',file
+              write(6,*)' ierr = ', ierr
+              CALL abort
+            ENDIF
+     
+c----------------------------------------------------------------------
+c   initialisation de la physique:
+c   ------------------------------
+
+c initialisations aux valeurs martiennes
+
+      rad=3397200.              ! rayon de mars (m)  ~3397200 m
+      daysec=88775.             ! duree du sol (s)  ~88775 s
+      omeg=4.*asin(1.)/(daysec) ! vitesse de rotation (rad.s-1)
+      g=3.72                    ! gravite (m.s-2) ~3.72
+      mugaz=43.49               ! Masse molaire de l''atm (g.mol-1) ~43.49
+      kappa=.256793             ! = r/cp  ~0.256793
+      r = 191.18213
+      pi=2.*asin(1.)
+      ecritphy =1
+      iphysiq=1
+      day_ini=0.
+      day_step=1
+   
+      WRITE (*,*) 'day0 = ' , day0
+
+      CALL iniconst
+      CALL inigeom
+      CALL inifilr
+
+c   sigma aux niveaux s:
+
+      DO l=1,llm
+         print*,'sig_s(',l,')  =  ',sig_s(l)
+      ENDDO
+
+c      Format Grads (Stats) : On suppose que l'on a 12 pas de temps :
+c      --------------------
+
+      nbpas=12
+      print*,'nbpas=',nbpas
+
+c======================================================================
+c   debut de la boucle sur les etats dans un fichier histoire:
+c======================================================================
+
+       itau= 1
+
+801    continue ! LOOP SUR LES PAS DE TEMPS START HERE
+
+       varname='u'
+       ierr =mcdreadnc(nid,varname,llm,u,itau)
+       varname='v'
+       ierr =mcdreadnc(nid,varname,llm,v,itau)
+       varname='temp'
+       ierr =mcdreadnc(nid,varname,llm,t,itau)
+       varname='ps'
+       ierr =mcdreadnc(nid,varname,1,ps,itau)
+c      PRINT*,'ps',ps(iip1/2,jjp1/2)
+       varname='tsurf'
+       ierr =mcdreadnc(nid,varname,1,tsurf,itau)
+c      PRINT*,'tsurf',tsurf(iip1/2,jjp1/2)
+
+c**********************************************************
+c  Traitement des donnees : (we are in LOOP on timestep)
+c**********************************************************
+
+
+c universal time (in stats file)
+c-------------------------------
+      utime = (itau-1)*2.
+
+c Longitude du point subterrestre
+c -------------------------------
+
+      tamp=(hlst-utime)*(iip1/24.)
+      if(tamp.GT.iip1) then
+      tamp=tamp-iip1
+      endif
+      if(tamp.LT.0)  then
+      tamp=iip1+tamp
+      endif
+      lonst=rlonv(nint(tamp))*180./pi
+      write(*,*) hlst,latst,lonst
+
+       lonst=(hlst-utime)*15
+       if(lonst.gt.180) lonst=lonst-180.
+       if(lonst.lt.-180) lonst=lonst+180.
+       write(*,*) hlst,latst,lonst
+
+c Local time
+c ----------
+
+c local time (in stats file)
+            DO i = 1,iim
+              localtime(i)=utime + 12.*rlonv(i)/pi
+              if(localtime(i).gt.24) localtime(i)=localtime(i)-24.
+              if(localtime(i).lt.0) localtime(i)=localtime(i)+24.
+	      heure(i)=localtime(i)
+c	      if(itau.EQ.1) heure(i)=0.375*(i-1)
+c	      if(itau.EQ.1) print*,heure(i)
+            ENDDO
+
+c              if(itau.EQ.1) heure(iip1)=24.
+	       heure(iip1)=localtime(1)
+
+c ******************************************
+
+
+c c Passage en niveaux de pression
+c --------------------------------
+
+          call xsig2p (ps,T,pref,llm,Tp)
+          call xsig2p (ps,u,pref,llm,up)
+          call xsig2p (ps,v,pref,llm,vp)
+
+c         Test temporaire
+c          do l=1, llm
+c             write(77,*) pref(l),up(1,1,l)
+c          end do
+
+c Traitement des donnees -> creation de spectres synthetiques
+c -----------------------------------------------------------
+
+c calcul des vitesses projetees
+
+      do l=1,llm
+         do j=1,jjp1
+            do i=1,iip1
+
+
+               up(i,j,l)=(242.*cos(rlatu(j))+up(i,j,l))*
+     .              sin(rlonv(i)-lonst*pi/180)*cos(latst*pi/180)
+
+
+           vp(i,j,l)=vp(i,j,l)*(cos(rlonv(i)-lonst*pi/180)*sin(rlatu(j))
+     .    *cos(latst*pi/180)-sin(latst*pi/180)*cos(rlatu(j)))
+
+
+            enddo
+         enddo
+      enddo
+
+c synthese des spectres
+
+c	print*,'itau=',itau,nbpas
+
+      call spectre2(itau,iraie,latst,lonst,olon,olat,
+     .vp,up,tp,ps,tsurf)
+
+
+	
+c  Fin de la boucle sur les pas de temps ? : (we are in LOOP on timestep)
+c  ****************************************
+
+      itau=itau+1
+
+      if(itau.gt.nbpas) then
+         ierr = NF_CLOSE(nid)
+         write(*,*) 'Si vous voulez entrer un nouveau fichier'
+         print*,'entrez son nom. Sinon, RETURN'
+            READ(5,'(a)') nomfich
+         if (nomfich(1:lnblnk(nomfich)).eq."") then
+            print*,'OK, on termine la'
+         else
+            file=nomfich(1:lnblnk(nomfich))
+            PRINT*,'file',file
+            goto 800
+         endif
+      else
+         goto 801
+      endif
+
+ 900   continue
+
+
+9999  PRINT*,'Fin '
+1000  format(a5,3x,i4,i3,x,a39)
+7777  FORMAT ('latitude/longitude',4f7.1)
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/bernoui.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/bernoui.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/bernoui.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn.F	(revision 57)
@@ -0,0 +1,125 @@
+      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,tourpot,vitvert,sortvarc,
+     *          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
+c     write (38,*) "convm: ",convm
+c     write (38,*) "airesurg: ",airesurg
+c     write (38,*) "iip1: ",iip1
+c     close (38)
+
+
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn0.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn0.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/caldyn0.F	(revision 57)
@@ -0,0 +1,88 @@
+      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,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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/calfis.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/calfis.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/calfis.F	(revision 57)
@@ -0,0 +1,547 @@
+      SUBROUTINE calfis(nq, lafin, rdayvrai,rday_ecri, heure,
+     $            pucov,pvcov,pteta,pq,pmasse,pps,pp,ppk,pphis,pphi,
+     $            pducov,pdvcov,pdteta,pdq,pw,
+     $            pdufi,pdvfi,pdhfi,pdqfi,pdpsfi,tracer )
+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       pw              flux vertical (kg m-2)
+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        tracer         Call tracer in  gcm.F ? (decided in callphys.def)
+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)
+      logical tracer
+
+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 zvervel(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)
+      SAVE latfi, lonfi, airefi
+
+      LOGICAL firstcal, debut
+      DATA firstcal/.true./
+      SAVE firstcal,debut
+      REAL rdayvrai,rday_ecri
+c
+c-----------------------------------------------------------------------
+c
+c    1. Initialisations :
+c    --------------------
+c
+
+
+      IF (ngridmx.NE.2+(jjm-1)*iim) THEN
+         PRINT*,'STOP dans calfis'
+         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
+         PRINT*,'  ngridmx  jjm   iim   '
+         PRINT*,ngridmx,jjm,iim
+         STOP
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   latitude, longitude et aires des mailles pour la physique:
+c   ----------------------------------------------------------
+
+c
+      IF ( firstcal )  THEN
+          debut = .TRUE.
+      ELSE
+          debut = .FALSE.
+      ENDIF
+
+c
+      IF (firstcal) THEN
+         latfi(1)=rlatu(1)
+         lonfi(1)=0.
+         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)
+
+         CALL inifis(ngridmx,llm,day_ini,daysec,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
+         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
+              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
+
+      ENDDO
+
+      DO l=1, llm
+        DO ig=1,ngridmx
+             if (ztfi(ig,l).lt.15) then
+                  write(*,*) 'New Temperature below 15 K !!! '
+	              write(*,*) 'Stop in calfis.F '
+	              write(*,*) 'ig=', ig, 'l= ', l
+                  stop
+             end if
+        ENDDO
+      ENDDO
+
+
+
+c   43.bis Taceurs (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   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 (m/s) pour diagnostique 
+c   -------------------------------
+c     pw est en kg/s
+c On interpole "lineairement" la temperature entre les couches(FF,10/95)
+
+      DO ig=1,ngridmx
+         zvervel(ig,1)=0.
+      END DO
+      DO l=2,llm
+        zvervel(1,l)=(pw(1,1,l)/apoln)
+     &  * r *0.5*(ztfi(1,l)+ztfi(1,l-1)) /zplev(1,l)              
+        ig0=2
+       DO j=2,jjm
+           DO i = 1, iim
+              zvervel(ig0,l) = pw(i,j,l) * unsaire(i,j)
+     &        * r *0.5*(ztfi(ig0,l)+ztfi(ig0,l-1)) /zplev(ig0,l)              
+              ig0 = ig0 + 1
+           ENDDO
+       ENDDO
+        zvervel(ig0,l)=(pw(1,jjp1,l)/apols)
+     &  * r *0.5*(ztfi(ig0,l)+ztfi(ig0,l-1)) /zplev(ig0,l)              
+      ENDDO
+
+c    .........  Reindexation : calcul de zvervel au MILIEU des couches
+       DO l=1,llm-1
+	      DO ig=1,ngridmx
+		     zvervel(ig,l) = 0.5*(zvervel(ig,l)+zvervel(ig,l+1))
+          END DO 
+       END DO 
+c      (dans la couche llm, on garde la valeur à la limite inférieure llm)
+
+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) )
+            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) )
+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) )
+            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
+         zvfi(1,l)  = SSUM(iim,zsin,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
+         zvfi(ngridmx,l)  = SSUM(iim,zsin,1)/pi
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   Appel de la physique:
+c   ---------------------
+
+
+      CALL physiq (ngridmx,llm,nq,
+     ,     debut,lafin,
+     ,     rday_ecri,heure,dtphys,
+     ,     zplev,zplay,zphi,
+     ,     zufi, zvfi,ztfi, zqfi,  
+     ,     zvervel,
+C - sorties
+     s     zdufi, zdvfi, zdtfi, zdqfi,zdpsrf,tracer)
+
+
+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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/clesph0.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/clesph0.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/clesph0.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coefpoly.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coefpoly.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coefpoly.F	(revision 57)
@@ -0,0 +1,38 @@
+c $Header: /users/lmdz/cvsroot/LMDZ.3.3/libf/dyn3d/coefpoly.F,v 1.1 2001/04/23 08:43:28 lmdz Exp $
+      SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 ,
+     ,                                          a0,a1,a2,a3         )
+      IMPLICIT NONE
+c
+c   ...  Auteur :   P. Le Van  ...
+c
+c
+c    Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui
+c      satisfait aux 4 equations  suivantes :
+
+c    a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1
+c    a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2
+c               a1  +     2.*a2*xtild1 +     3.*a3*xtild1*xtild1 = Xprim1
+c               a1  +     2.*a2*xtild2 +     3.*a3*xtild2*xtild2 = Xprim2
+
+c  On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3
+
+      REAL*8 Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi 
+      REAL*8 Xfout, Xprim
+      REAL*8 a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car
+
+      xtil1car = xtild1 * xtild1
+      xtil2car = xtild2 * xtild2 
+
+      derr= 2. *(Xf2-Xf1)/( xtild1-xtild2)
+
+      x1x2car = ( xtild1-xtild2)*(xtild1-xtild2)
+
+      a3 = (derr + Xprim1+Xprim2 )/x1x2car
+      a2     = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) )    /
+     /           (  2.* ( xtild1 - xtild2 )  )
+
+      a1     = Xprim1 -3.* a3 * xtil1car     -2.* a2 * xtild1
+      a0     =  Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comav.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comav.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comav.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comconst.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comconst.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comconst.h	(revision 57)
@@ -0,0 +1,13 @@
+!-----------------------------------------------------------------------
+! 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
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdiss.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdiss.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdiss.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissip.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissip.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissip.h	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c INCLUDE dissip.h
+
+      COMMON/comdissip/
+     $    niterdis,coefdis,tetavel,tetatemp,gamdissip
+
+
+      INTEGER niterdis
+
+      REAL tetavel,tetatemp,coefdis,gamdissip
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissipn.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissipn.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissipn.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissnew.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissnew.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comdissnew.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom.h	(revision 57)
@@ -0,0 +1,29 @@
+!CDK comgeom
+      COMMON/comgeom/
+     .cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),
+     .aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),
+     .airev(ip1jm),unsaire(ip1jmp1),apoln,apols,
+     .unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),
+     .aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),
+     .aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),
+     .alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),
+     .alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),
+     .fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),
+     .rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),
+     .cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),
+     .cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),
+     .cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),
+     .unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,
+     .unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),
+     .aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+      REAL :: 
+     .cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,
+     .apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,
+     .alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,
+     .fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,
+     .cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2,
+     .unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,
+     .aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu,
+     .xprimv
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom2.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom2.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comgeom2.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comvert.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comvert.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/comvert.h	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'comvert.h'
+
+      COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm) ,
+     .               pa,preff,nivsigs(llm),nivsig(llm+1),
+     .               sig(llm+1),ds(llm),aps(llm),bps(llm),pseudoalt(llm)
+
+      REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig
+c Mars Ce qui suit vient de gcm
+      REAL sig,ds,aps,bps,pseudoalt
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/control.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/control.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/control.h	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'control.h'
+
+      COMMON/control/nday,day_step,
+     $              iperiod,iconser,idissip,iphysiq ,
+     $              periodav,ecritphy,anneeref
+
+      INTEGER   nday,day_step,iperiod,iconser,
+     $          idissip,iphysiq,anneeref
+      REAL periodav, ecritphy
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convflu.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convflu.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convflu.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convmas.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convmas.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/convmas.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coordij.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coordij.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/coordij.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covcont.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covcont.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covcont.F	(revision 57)
@@ -0,0 +1,41 @@
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covnat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covnat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/covnat.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/defrun_new.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/defrun_new.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/defrun_new.F	(revision 57)
@@ -0,0 +1,501 @@
+      SUBROUTINE defrun_new( tapedef, etatinit )
+c
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c     Auteurs :   L. Fairhead , P. Le Van  .
+c      Modif C. Hourdin F. Forget VERSION MARTIENNE
+c
+c
+c  -------------------------------------------------------------------
+c
+c                    MODIF JUIN 2000 (zoom)
+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 : ** 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_new  est appele dans NEWSTART
+c   ETAT0_LMD  ou  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  alphax ,
+c   alphay,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 parametres definissant entre autres la grille et doivent etre
+c   pareils et coherents , sinon il y aura  divergence du gcm .
+c
+c
+c-----------------------------------------------------------------------
+c   Declarations :
+c   --------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "sponge.h"
+c
+c   arguments:
+c   ---------
+      LOGICAL  etatinit ! should be .false. for a call from gcm.F
+                        ! and .true. for a call from newstart.F
+      INTEGER  tapedef  ! unit number to assign to 'run.def' file
+c
+c   local variables:
+c   ---------------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*8 ! to store various strings
+      INTEGER tapeout ! unit numbers for (standard) outputs
+      parameter (tapeout=6)
+      integer tapeerr ! unit number for error message
+      parameter (tapeerr=0)
+
+c     REAL clonn,clatt,alphaxx,alphayy
+c     LOGICAL  fxyhypbb
+      INTEGER ierr
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy,tauxx,tauyy,temp
+      LOGICAL  fxyhypbb, ysinuss
+
+
+c   initialisations:
+c   ----------------
+ 
+!      tapeout=6
+
+c-----------------------------------------------------------------------
+c  Parametres de controle du run:
+c-----------------------------------------------------------------------
+
+
+!Initialisation des parametres "terrestres", qui ne concernent pas
+!le modele martien et ne sont donc plus lues dans "run.def"
+
+        anneeref=0
+        ! Note: anneref is a common in 'control.h'
+
+      OPEN(tapedef,file='run.def',status='old',form='formatted'
+     .     ,iostat=ierr)
+
+      IF(ierr.EQ.0) THEN ! if file run.def is found
+
+        WRITE(tapeout,*) "DEFRUN: reading file run.def"
+        READ (tapedef,9000) ch1,ch2,ch3
+        WRITE(tapeout,9000) ch1,ch2,ch3
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    nday
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'nday       ',nday
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    day_step
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'day_step   ',day_step
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    iperiod
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'iperiod    ',iperiod
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    iconser
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'iconser    ',iconser
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    temp
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9006) 'iecri not used'
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    periodav
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'periodav   ',periodav
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    idissip
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'idissip    ',idissip
+
+ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+ccc
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    lstardis
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'lstardis   ',lstardis
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    hybrid
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'hybrid ',hybrid
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    nitergdiv
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'nitergdiv  ',nitergdiv
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    nitergrot
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'nitergrot  ',nitergrot
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    niterh
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'niterh     ',niterh
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    tetagdiv
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'tetagdiv   ',tetagdiv
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    tetagrot
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'tetagrot   ',tetagrot
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    tetatemp
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'tetatemp   ',tetatemp
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    coefdis
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'coefdis    ',coefdis
+c
+c    ...............................................................
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    purmats
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'purmats    ',purmats
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    physic
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'physic     ',physic
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    iphysiq
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'iphysiq    ',iphysiq
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    grireg
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'grireg     ',grireg
+
+ccc   .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ...
+c
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ecritphy
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'ecritphy   ',ecritphy
+
+
+ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+c     .........   (  modif  le 17/04/96 )   .........
+c
+        if (.not.etatinit ) then 
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    clonn
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'clon       ',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,9002) ch1
+           WRITE(tapeout,9003) 'clat       ',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,9002) ch1
+           WRITE(tapeout,9003) 'grossismx  ',grossismxx
+
+           if(grossismxx.eq.0) then  
+             write(*,*)
+             write(*,*)'ERREUR : dans run.def, grossismx =0'
+             write(*,*)'Attention a ne pas utiliser une version de'
+             write(*,*)'run.def avant le nouveau zoom LMDZ2.3 (06/2000)'
+             write(*,*)'(Il faut ajouter grossismx,dzoomx,etc... a la'
+             write(*,*)'place de alphax, alphay. cf. dyn3d). '
+             write(*,*)
+             stop
+           end if
+
+           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 =',
+     *        grossismx
+             if (grossismx.eq.0) then
+                  write(*,*) 'OK,Normal : c est un vieux start'
+     *             , 'd avant le nouveau zoom LMDZ2.3 (06/2000)'
+                 grossismx=grossismxx
+             else
+                   STOP
+             endif
+           ENDIF
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    grossismyy
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'grossismy  ',grossismyy
+
+           IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+             PRINT *,' La valeur de grossismy passee par run.def est '
+     *       ,'differente de celle lue sur le fichier  start =',
+     *        grossismy
+             if (grossismy.eq.0) then
+                  write(*,*) 'OK,Normal : c est un vieux start'
+     *             , 'd avant le nouveau zoom LMDZ2.3 (06/2000)'
+                 grossismy=grossismyy
+             else
+                   STOP
+             endif
+           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 *,' '
+           PRINT *,' --> In defrun: alphax alphay  ',alphax,alphay
+           PRINT *,' '
+c
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    fxyhypbb
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9004) 'fxyhypbb   ',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
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    dzoomxx
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'dzoomx  ',dzoomxx
+
+           IF( fxyhypb )  THEN
+              IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+                PRINT *,' La valeur de dzoomx passee par run.def est '
+     *          ,'differente de celle lue sur le fichier  start '
+                STOP
+              ENDIF
+           ENDIF
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    dzoomyy
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'dzoomy  ',dzoomyy
+
+           IF( fxyhypb )  THEN
+              IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+                PRINT *,' La valeur de dzoomy passee par run.def est '
+     *          ,'differente de celle lue sur le fichier  start '
+                STOP
+              ENDIF
+           ENDIF
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    tauxx
+           WRITE(tapeout,9001) ch1,'taux'
+           WRITE(tapeout,*)    tauxx
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    tauyy
+           WRITE(tapeout,9001) ch1,'tauy'
+           WRITE(tapeout,*)    tauyy
+
+           IF( fxyhypb )  THEN
+              IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+                WRITE(6,*)' La valeur de taux passee par run.def est', 
+     *             'differente de celle lue sur le fichier  start '
+                CALL ABORT
+              ENDIF
+
+              IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+                WRITE(6,*)' La valeur de tauy passee par run.def est',
+     *          'differente de celle lue sur le fichier  start '
+                CALL ABORT
+              ENDIF
+           ENDIF
+  
+        ELSE    ! Below, case when etainit=.true.
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    clon
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'clon       ',clon
+c
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    clat
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'clat       ',clat
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    grossismx
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'grossismx  ',grossismx
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    grossismy
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'grossismy  ',grossismy
+
+           IF( grossismx.LT.1. )  THEN
+            PRINT *,' ***  ATTENTION !! grossismx < 1 .   *** '
+            STOP
+           ELSE
+             alphax = 1. - 1./ grossismx
+           ENDIF
+
+           IF( grossismy.LT.1. )  THEN
+             PRINT *,' ***  ATTENTION !! grossismy < 1 .   *** '
+             STOP
+           ELSE
+             alphay = 1. - 1./ grossismy
+           ENDIF
+
+           PRINT *,' Defrun  alphax alphay  ',alphax,alphay
+c
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    fxyhypb
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9004) 'fxyhypb  ',fxyhypb
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    dzoomx
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'dzoomx   ',dzoomx
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    dzoomy
+           WRITE(tapeout,9002) ch1
+           WRITE(tapeout,9003) 'dzoomy   ',dzoomy
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    taux
+           WRITE(tapeout,9001) ch1,'taux'
+           WRITE(tapeout,*)    taux
+
+           READ (tapedef,9001) ch1,ch4
+           READ (tapedef,*)    tauy
+           WRITE(tapeout,9001) ch1,'tauy'
+           WRITE(tapeout,*)    tauy
+
+        END IF ! of if (.not.etatinit )
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    ysinus
+        WRITE(tapeout,9001) ch1,'ysinus'
+        WRITE(tapeout,*)    ysinus
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    callsponge
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9004) 'callsponge ',callsponge
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    mode_sponge
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9005) 'mode_sponge',mode_sponge
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    hsponge
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'hsponge    ',hsponge
+
+        READ (tapedef,9001) ch1,ch4
+        READ (tapedef,*)    tetasponge
+        WRITE(tapeout,9002) ch1
+        WRITE(tapeout,9003) 'tetasponge ',tetasponge
+
+
+      WRITE(tapeout,*) '-----------------------------------------------'
+      WRITE(tapeout,*) ' '
+      WRITE(tapeout,*) ' '
+c
+
+c       Unlike on Earth (cf LMDZ2.2) , always a regular grid on Mars :
+        ysinus = .false. !Mars Mettre a jour
+
+
+      WRITE(tapeout,*) '-----------------------------------------------'
+      WRITE(tapeout,*) ' '
+      WRITE(tapeout,*) ' '
+cc
+      ELSE
+        write(tapeerr,*) ' WHERE IS run.def ? WE NEED IT !!!!!!!!!!!!!!'
+        stop
+      ENDIF ! of IF(ierr.eq.0)
+
+c     Test sur le zoom
+
+      if((grossismx.eq.1).and.(grossismy.eq.1)) then  
+c        Pas de zoom :
+         write(tapeout,*) 'No zoom ? -> fxyhypb set to False'
+     &   ,'           (It runs better that way)'
+         fxyhypb = .false.
+      else     
+c        Avec Zoom
+         if (.not.fxyhypb) stop 'With zoom, fxyhypb should be set to T 
+     &in run.def for this version... -> STOP ! '     
+      end if
+
+      RETURN
+c
+9000  FORMAT(3(/,a72))
+9001  FORMAT(/,a72,/,a9)
+9002  FORMAT(/,a72)
+9003  FORMAT(t3,a11,t14,f9.3)
+9004  FORMAT(t3,a11,t14,l9)
+9005  FORMAT(t3,a11,t14,i9)
+9006  FORMAT(t3,a14)
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/description.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/description.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/description.h	(revision 57)
@@ -0,0 +1,2 @@
+      character *120 descript
+      common /titre/descript
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diagadv.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diagadv.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diagadv.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dissip.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dissip.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dissip.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.F	(revision 57)
@@ -0,0 +1,300 @@
+      SUBROUTINE disvert 
+
+c    Auteur :  F. Forget Y. Wanherdrick, P. Levan
+c    Nouvelle version 100% Mars !!
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "logic.h"
+c
+c=======================================================================
+c    Discretisation verticale en coordonnée hybride OU sigma
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+c
+      INTEGER l,ll
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h,quoi,quand
+      REAL zsig(llm)
+      INTEGER np,ierr
+      integer :: ierr1,ierr2,ierr3,ierr4
+      REAL x
+
+      REAL SSUM
+      EXTERNAL SSUM
+      real newsig 
+      REAL dz0,dz1,nhaut,sig1,esig,csig,zz
+      real tt,rr,gg, prevz
+      real s(llm),dsig(llm) 
+
+      integer iz 
+      real z, ps,p
+
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+! Ouverture possible de fichiers typiquement E.T.
+
+         open(99,file="esasig.def",status='old',form='formatted',
+     s   iostat=ierr2)
+         if(ierr2.ne.0) then
+              close(99)
+              open(99,file="z2sig.def",status='old',form='formatted',
+     s        iostat=ierr4)
+         endif
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans esasig.def:
+c   ----------------------------------------
+
+      IF(ierr2.eq.0) then
+
+c        Lecture de esasig.def :
+c        Systeme peu souple, mais qui respecte en theorie
+c        La conservation de l'energie (conversion Energie potentielle
+c        <-> energie cinetique, d'apres la note de Frederic Hourdin...
+
+         PRINT*,'*****************************'
+         PRINT*,'WARNING Lecture de esasig.def'
+         PRINT*,'*****************************'
+         READ(99,*) h
+         READ(99,*) dz0
+         READ(99,*) dz1
+         READ(99,*) nhaut
+         CLOSE(99)
+
+         dz0=dz0/h
+         dz1=dz1/h
+
+         sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
+
+         esig=1.
+
+         do l=1,20
+            esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
+         enddo
+         csig=(1./sig1-1.)/(exp(esig)-1.)
+
+         DO L = 2, llm
+            zz=csig*(exp(esig*(l-1.))-1.)
+            sig(l) =1./(1.+zz)
+     &      * tanh(.5*(llm+1-l)/nhaut)
+         ENDDO
+         sig(1)=1.
+         sig(llm+1)=0.
+         quoi      = 1. + 2.* kappa
+         s( llm )  = 1.
+         s(llm-1) = quoi
+         IF( llm.gt.2 )  THEN
+            DO  ll = 2, llm-1
+               l         = llm+1 - ll
+               quand     = sig(l+1)/ sig(l)
+               s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
+            ENDDO
+         END IF
+c
+         snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
+         DO l = 1, llm
+            s(l)    = s(l)/ snorm
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   cas 2 on lit les options dans z2sig.def:
+c   ----------------------------------------
+
+      ELSE IF(ierr4.eq.0) then
+         PRINT*,'****************************'
+         PRINT*,'Lecture de z2sig.def'
+         PRINT*,'****************************'
+
+         READ(99,*) h
+         do l=1,llm
+            read(99,*) zsig(l)
+         end do
+         CLOSE(99)
+
+         sig(1) =1
+         do l=2,llm
+           sig(l) = 0.5 * ( exp(-zsig(l)/h) + exp(-zsig(l-1)/h) )
+         end do
+         sig(llm+1) =0
+
+c-----------------------------------------------------------------------
+      ELSE
+         write(*,*) 'didn t you forget something ??? '
+         write(*,*) 'We need the file  z2sig.def ! (OR esasig.def) '
+         stop
+      ENDIF
+c-----------------------------------------------------------------------
+
+      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   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
+c-----------------------------------------------------------------------
+c
+
+      if (hybrid) then
+         write(*,*) "*******************************"
+         write(*,*) "Systeme en coordonnees hybrides"
+         write(*,*) 
+c        Coordonnees hybrides avec mod
+         DO l = 1, llm
+
+         call sig_hybrid(sig(l),pa,preff,newsig)
+            bp(l) = EXP( 1. - 1./(newsig**2)  )
+            ap(l) = pa * (newsig - bp(l) )
+         enddo
+         bp(llmp1) = 0.
+         ap(llmp1) = 0.
+      else
+         write(*,*) "****************************"
+         write(*,*) "Systeme en coordonnees sigma"
+         write(*,*) 
+c        Pour ne pas passer en coordonnees hybrides
+         DO l = 1, llm
+            ap(l) = 0.
+            bp(l) = sig(l)
+         ENDDO
+         ap(llmp1) = 0.
+      endif
+
+      bp(llmp1) =   0.
+
+      PRINT *,' BP '
+      PRINT *,  bp
+      PRINT *,' AP '
+      PRINT *,  ap
+
+c     Calcul au milieu des couches :
+c     WARNING : le choix de placer le milieu des couches au niveau de
+c     pression intermédiaire est arbitraire et pourrait etre modifié.
+c     Le calcul du niveau pour la derniere couche 
+c     (on met la meme distance (en log pression)  entre P(llm)
+c     et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
+c     Specifique.  Ce choix est spécifié ici ET dans exner_hyb.F
+
+      DO l = 1, llm-1
+       aps(l) =  0.5 *( ap(l) +ap(l+1)) 
+       bps(l) =  0.5 *( bp(l) +bp(l+1)) 
+      ENDDO
+     
+      if (hybrid) then
+         aps(llm) = aps(llm-1)**2 / aps(llm-2) 
+         bps(llm) = 0.5*(bp(llm) + bp(llm+1))
+      else
+         bps(llm) = bps(llm-1)**2 / bps(llm-2) 
+         aps(llm) = 0.
+      end if
+
+      PRINT *,' BPs '
+      PRINT *,  bps
+      PRINT *,' APs'
+      PRINT *,  aps
+
+      DO l = 1, llm
+       presnivs(l) = aps(l)+bps(l)*preff
+       pseudoalt(l) = -10.*log(presnivs(l)/preff)
+      ENDDO
+
+      PRINT *,' PRESNIVS' 
+      PRINT *,presnivs 
+      PRINT *,'Pseudo altitude des Presnivs : ' 
+      PRINT *,pseudoalt
+
+c     --------------------------------------------------
+c     This can be used to plot the vertical discretization
+c     (> xmgrace -nxy testhybrid.tab       (z = H*log(p(l)/pref))
+c     --------------------------------------------------
+c     open (53,file='testhybrid.tab')
+c     do iz=0,60
+c       z = -10 + min(iz,60-iz)
+c       ps = preff*exp(-z/10)
+c       do l=1,llm
+c          zsig(l)= -10.*log((aps(l) + bps(l)*ps)/preff)
+c       end do
+c       write(53,*)iz, (zsig(l),l=1,llm,1)
+c      end do
+c      close(53)
+c     --------------------------------------------------
+
+
+      RETURN
+      END
+
+c ************************************************************
+      subroutine sig_hybrid(sig,pa,preff,newsig)
+c     ----------------------------------------------
+c     Subroutine utilisee pour calculer des valeurs de sigma modifie
+c     pour conserver les coordonnees verticales decrites dans
+c     esasig.def/z2sig.def lors du passage en coordonnees hybrides
+c     F. Forget 2002
+c     Connaissant sig (niveaux "sigma" ou on veut mettre les couches)
+c     L'objectif est de calculer newsig telle que
+c       (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig
+c     Cela ne se résoud pas analytiquement: 
+c     => on résoud par iterration bourrine 
+c     ----------------------------------------------
+c     Information  : where exp(1-1./x**2) become << x
+c           x      exp(1-1./x**2) /x
+c           1           1
+c           0.68       0.5
+c           0.5        1.E-1
+c           0.391      1.E-2
+c           0.333      1.E-3
+c           0.295      1.E-4
+c           0.269      1.E-5
+c           0.248      1.E-6
+c        => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25
+
+
+      implicit none
+      real x1, x2, sig,pa,preff, newsig, F
+      integer j
+
+      newsig = sig
+      x1=0
+      x2=1
+	  if (sig.ge.1) then
+	       newsig= sig
+      else if (sig*preff/pa.ge.0.25) then
+        DO J=1,9999  ! nombre d''iteration max
+          F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig
+c         write(0,*) J, ' newsig =', newsig, ' F= ', F
+          if (F.gt.1) then
+              X2 = newsig
+              newsig=(X1+newsig)*0.5
+          else
+              X1 = newsig
+              newsig=(X2+newsig)*0.5
+          end if
+c         Test : on arete lorsque on approxime sig à moins de 0.01 m près 
+c         (en pseudo altiude) :
+          IF(abs(10.*log(F)).LT.1.E-5) goto 999
+        END DO
+       else   !    if (sig*preff/pa.le.0.25) then
+	        newsig= sig*preff/pa
+       end if
+ 999   continue
+       Return
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.orig
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.orig	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/disvert.orig	(revision 57)
@@ -0,0 +1,341 @@
+      SUBROUTINE disvert 
+
+c    Auteur :  P. Le Van . F. Forget Y. Wanherdrick
+c    Many modif special mars !!
+
+      IMPLICIT NONE
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "hybrid.h"
+c
+c=======================================================================
+c    Discretisation verticale en coordonnée hybride
+c
+c=======================================================================
+c
+c   declarations:
+c   -------------
+c
+c
+      INTEGER l,ll
+      REAL snorm
+      REAL alpha,beta,gama,delta,deltaz,h,zsig,quoi,quand
+      INTEGER np,ierr
+      integer :: ierr1,ierr2,ierr3,ierr4
+      REAL x
+
+      REAL SSUM
+      EXTERNAL SSUM
+      real newsig 
+      REAL dz0,dz1,nhaut,sig1,esig,csig,zz
+      real tt,rr,gg, prevz
+      real s(llm),dsig(llm) 
+
+c
+c-----------------------------------------------------------------------
+c
+      pi=2.*ASIN(1.)
+
+      open(99,file="sigma.def",status='old',form='formatted',
+     s   iostat=ierr1)
+! Ouverture possible de fichiers typiquement E.T.
+
+      if(ierr1.ne.0) then
+         close(99)
+         open(99,file="esasig.def",status='old',form='formatted',
+     s   iostat=ierr2)
+         if(ierr2.ne.0) then
+            close(99)
+            open(99,file="tritonsig.def",status='old',form='formatted',
+     s      iostat=ierr3)
+            if(ierr3.ne.0) then
+              close(99)
+              open(99,file="z2sig.def",status='old',form='formatted',
+     s        iostat=ierr4)
+            endif
+         endif
+      endif
+
+c-----------------------------------------------------------------------
+c   cas 1 on lit les options dans sigma.def:
+c   ----------------------------------------
+
+      IF (ierr1.eq.0) THEN
+
+         PRINT*,'*****************************'
+         PRINT*,'WARNING Lecture de sigma.def'
+         PRINT*,'*****************************'
+      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 l = 1, llm
+          dsig(l) = (alpha+(1.-alpha)*exp(-beta*(llm-l)))*
+     $          ( (tanh(gama*l)/tanh(gama*llm))**np +
+     $            (1.-l/FLOAT(llm))*delta )
+       ENDDO
+
+       sig(1)=1.
+       DO l=1,llm-1
+          sig(l+1)=sig(l)*(1.-dsig(l))/(1.+dsig(l))
+       ENDDO
+       sig(llm+1)=0.
+
+c
+
+! Debut de la partie martienne pour lecture de esasig.def
+c=========================================================
+
+      ELSE IF(ierr2.eq.0) then
+
+         PRINT*,'*****************************'
+         PRINT*,'WARNING Lecture de esasig.def'
+         PRINT*,'*****************************'
+         READ(99,*) h
+         READ(99,*) dz0
+         READ(99,*) dz1
+         READ(99,*) nhaut
+         CLOSE(99)
+
+         dz0=dz0/h
+         dz1=dz1/h
+
+         sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut)
+
+         esig=1.
+
+         PRINT*
+         do l=1,20
+            esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.)
+         enddo
+         print*,'esig=',esig
+         PRINT*
+         csig=(1./sig1-1.)/(exp(esig)-1.)
+
+         DO L = 2, llm
+            zz=csig*(exp(esig*(l-1.))-1.)
+            sig(l) =1./(1.+zz)
+     &      * tanh(.5*(llm+1-l)/nhaut)
+         ENDDO
+         sig(1)=1.
+         sig(llm+1)=0.
+
+c Fin de la partie martienne
+c ==========================
+
+      ELSE IF(ierr3.eq.0) then
+
+         PRINT*,'********************************'
+         PRINT*,'WARNING Lecture de tritonsig.def'
+         PRINT*,'********************************'
+         PRINT*,'kappa=', kappa
+         READ(99,*) gg
+         READ(99,*) rr
+         sig(1)=1.
+         prevz=0.
+         do l=1,llm-1
+           read(99,*) zz, tt
+           sig(l+1) = sig(l)* exp(-(zz-prevz)*gg/(rr*tt))
+           prevz=zz
+           if(l.eq.llm/2)h =1.e-3* rr*tt/gg
+         end do
+         sig(llm+1)=0.
+         CLOSE(99)
+
+      ELSE IF(ierr4.eq.0) then
+         PRINT*,'****************************'
+         PRINT*,'WARNING Lecture de z2sig.def'
+         PRINT*,'****************************'
+
+
+         READ(99,*) h
+         do l=1,llm
+            read(99,*) zsig
+            s(l) = exp(-kappa*zsig/h)
+         end do
+         CLOSE(99)
+
+         sig(1) =1
+         do l=2,llm
+           sig(l) = 0.5 * (s(l)**(1/kappa)+s(l-1)**(1/kappa))
+         end do
+         sig(llm+1) =0
+
+      ELSE
+c-----------------------------------------------------------------------
+c   cas 2 ancienne discretisation (LMD5...):
+c   ----------------------------------------
+
+      PRINT*,'********************************************'
+      PRINT*,'WARNING!!! Ancienne discretisation verticale'
+      PRINT*,'********************************************'
+      stop ! interdit sur MARS
+      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
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+        nivsigs(l) = FLOAT(l)
+      ENDDO
+
+      DO l=1,llmp1
+        nivsig(l)= FLOAT(l)
+      ENDDO
+
+c    On ne recalcule s que dans les cas "classique"
+c    (esasig.def, sigma.def, ou ancienne discretisation sans fichier)
+      IF( (ierr1.eq.0) .or. (ierr2.eq.0)
+     &   .or. ((ierr3.ne.0).and.(ierr4.ne.0)) ) then
+         quoi      = 1. + 2.* kappa
+         s( llm )  = 1.
+         s(llm-1) = quoi
+         IF( llm.gt.2 )  THEN
+            DO  ll = 2, llm-1
+               l         = llm+1 - ll
+               quand     = sig(l+1)/ sig(l)
+               s(l-1)    = quoi * (1.-quand) * s(l)  + quand * s(l+1)
+            ENDDO
+         END IF
+c
+         snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2)
+         DO l = 1, llm
+            s(l)    = s(l)/ snorm
+         ENDDO
+      END IF
+
+c
+c    ....  Calculs  de ap(l) et de bp(l)  ....
+c    .........................................
+c
+c
+c   .....  pa et preff sont lus  sur les fichiers start par dynetat0 .....
+c
+
+
+      if (hybrid) then
+         write(*,*) "*******************************"
+         write(*,*) "Systeme en coordonnees hybrides"
+         write(*,*) 
+c        Coordonnees hybrides avec mod
+         write(*,*) "sig disvert",sig
+         DO l = 1, llm
+            call sig_hybrid(sig(l),pa,preff,1.e-6,newsig)
+            bp(l) = EXP( 1. -1./( newsig*newsig) )
+            ap(l) = pa * (newsig - bp(l) )
+         enddo
+         call sig_hybrid(sig(llmp1),pa,preff,1.e-6,newsig)
+         ap(llmp1) = pa * ( newsig - bp(llmp1) )
+      else
+         write(*,*) "****************************"
+         write(*,*) "Systeme en coordonnees sigma"
+         write(*,*) 
+c        Pour ne pas passer en coordonnees hybrides
+         DO l = 1, llm
+            ap(l) = 0.
+            bp(l) = sig(l)
+         ENDDO
+         ap(llmp1) = 0.
+      endif
+
+      bp(llmp1) =   0.
+
+      PRINT *,' BP '
+      PRINT *,  bp
+      PRINT *,' AP '
+      PRINT *,  ap
+
+c     Calcul au milieu des couches :
+c     WARNING : le choix de placer le milieu des couches au niveau de
+c     pression intermédiaire est arbitraire et pourrait etre modifié.
+c     Le calcul du niveau pour la derniere couche 
+c     (on met la meme distance (en log pression)  entre P(llm)
+c     et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est
+c     Specifique.  Ce choix est spécifié ici ET dans exner_hyb.F
+
+      DO l = 1, llm-1
+       aps(l) =  0.5 *( ap(l) +ap(l+1)) 
+       bps(l) =  0.5 *( bp(l) +bp(l+1)) 
+      ENDDO
+     
+      if (hybrid) then
+         aps(llm) = ap(llm-1)**2 / ap(llm-2) 
+         bps(llm) = 0.5*(bp(llm) + bp(llm+1))
+      else
+         bps(llm) = bp(llm-1)**2 / bp(llm-2) 
+         aps(llm) = 0.
+      end if
+
+      PRINT *,' BPs '
+      PRINT *,  bps
+      PRINT *,' APs'
+      PRINT *,  aps
+
+      DO l = 1, llm
+       presnivs(l) = aps(l)+bps(l)*preff
+       pseudoalt(l) = -10.*log(presnivs(l)/preff)
+      ENDDO
+
+      PRINT *,' PRESNIVS' 
+      PRINT *,presnivs 
+      PRINT *,'Pseudo altitude des Presnivs : ' 
+      PRINT *,pseudoalt
+
+      RETURN
+      END
+
+c ************************************************************
+      subroutine sig_hybrid(sig,pa,preff,xacc,newsig)
+c     ----------------------------------------------
+c     Subroutine utilisee pour calculer des valeurs de sigma modifie
+c     pour conserver les coordonnees verticales decrites dans
+c     esasig.def/z2sig.def lors du passage en coordonnees hybrides
+c     F. Forget 2002
+c     ----------------------------------------------
+      implicit none
+      real x1, x2, xacc, sig,pa,preff, newsig, F
+      integer j
+
+      newsig = sig
+      x1=0
+      x2=1
+      if ((sig.ne.0).and.(sig.ne.1)) then
+        DO J=1,9999  ! nombre d''iteration max
+          F=(1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig -sig
+          if (F.gt.0) then
+              X2 = newsig
+              newsig=(X1+newsig)*0.5
+          else
+              X1 = newsig
+              newsig=(X2+newsig)*0.5
+          end if
+c       write(0,*) J, ' newsig =', newsig, ' F= ', F
+
+        IF(X2-X1.LT.XACC) RETURN
+        END DO
+       end if
+       Return
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg_gam.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg_gam.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/diverg_gam.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergf.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergf.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergf.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergst.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergst.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divergst.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad2.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad2.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad2.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad22.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad22.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/divgrad22.F	(revision 57)
@@ -0,0 +1,55 @@
+      SUBROUTINE divgrad2_mars (klevel,h, lh, divgra )
+c
+c  P. Le Van
+c
+c   ************************************************************
+c
+c                                lh
+c        calcul de  (div( grad ))   de h  .....
+c   ************************************************************
+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
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissipn.h"
+
+      INTEGER klevel
+      REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel )
+c
+      REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm)
+      REAL signe, nudivgrs
+
+      INTEGER  l,ij,iter,lh
+
+      EXTERNAL  filtreg
+      EXTERNAL  SCOPY, grad, covcont, diverg, divergst
+
+
+      signe    = (-1.)**lh
+      nudivgrs = signe * cdivh
+
+      CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 )
+
+      DO 2 iter = 1, lh -1
+      CALL grad (klevel,divgra, ghx  , ghy          )
+      CALL divergst (klevel,  ghx , ghy  , divgra       )
+   2  CONTINUE
+
+      CALL filtreg (divgra,jjp1,klevel,2,1,.true.,1)
+      CALL grad  (klevel,divgra, ghx, ghy      )
+      CALL covcont (klevel,ghx   , ghy, 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 ) = nudivgrs * divgra( ij,l )
+   4  CONTINUE
+   5  CONTINUE
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dteta1.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dteta1.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dteta1.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv1.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv1.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv1.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv2.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv2.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dudv2.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dump2d.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dump2d.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dump2d.F	(revision 57)
@@ -0,0 +1,43 @@
+      SUBROUTINE dump2d(im,jm,z,nom_z)
+      IMPLICIT NONE
+      INTEGER im,jm
+      REAL z(im,jm)
+      CHARACTER (len=*) :: nom_z
+
+      INTEGER i,j,imin,illm,jmin,jllm
+      REAL zmin,zllm
+
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynetat0.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynetat0.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynetat0.F	(revision 57)
@@ -0,0 +1,413 @@
+      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(iip1,jjp1,llm,nq),masse(ip1jmp1,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+
+      REAL time
+
+c   Variables 
+c
+      INTEGER length,iq,i,j,l
+      PARAMETER (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER ierr, nid, nvarid, nqold
+      CHARACTER  str3*3,yes*1
+
+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 ',fichnom
+        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)
+      rad        = tab_cntrl(5)
+      omeg       = tab_cntrl(6)
+      g          = tab_cntrl(7)
+      cpp        = tab_cntrl(8)
+      kappa      = tab_cntrl(9)
+      daysec     = tab_cntrl(10)
+      dtvr       = tab_cntrl(11)
+      etot0      = tab_cntrl(12)
+      ptot0      = tab_cntrl(13)
+      ztot0      = tab_cntrl(14)
+      stot0      = tab_cntrl(15)
+      ang0       = tab_cntrl(16)
+      pa         = tab_cntrl(17)
+      preff      = tab_cntrl(18)
+c
+      clon       = tab_cntrl(19)
+      clat       = tab_cntrl(20)
+      grossismx  = tab_cntrl(21)
+      grossismy  = tab_cntrl(22)
+c
+      IF ( tab_cntrl(23).EQ.1. )  THEN
+        fxyhypb  = . TRUE .
+        dzoomx   = tab_cntrl(24)
+        dzoomy   = tab_cntrl(25)
+        taux     = tab_cntrl(27)
+        tauy     = tab_cntrl(28)
+      ELSE
+        fxyhypb = . FALSE .
+        ysinus  = . FALSE .
+        IF( tab_cntrl(26).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, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+	     ierr = NF_INQ_VARID (nid, "temps", nvarid)
+		 IF (ierr .NE. NF_NOERR) THEN
+           PRINT*, "dynetat0: <Time> or <temps> absent"
+           CALL abort
+         ENDIF
+      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 <Time>/<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
+
+         IF(nq.GT.99) THEN
+            PRINT*, "Trop de traceurs"
+            CALL abort
+         ENDIF
+         nqold=nq
+         DO iq=1,nq
+           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*, "dynetat0: Le champ <"//str3//"> est absent"
+              PRINT*, "          Il est donc initialise a zero"
+              CALL initial0(ijp1llm,q(1,1,1,iq))
+              nqold=min(iq-1,nqold)
+           ELSE
+#ifdef NC_DOUBLE
+           ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,1,iq))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,1,iq))
+#endif
+              IF (ierr .NE. NF_NOERR) THEN
+                 PRINT*, "dynetat0: Lecture echouee pour "//str3
+                 CALL abort
+              ENDIF
+           ENDIF
+         ENDDO
+         if(nqold.lt.nq) then   
+c        case when new tracer are added in addition to old ones
+             write(*,*)'tracers 1 to ', nqold,'were already present'
+             write(*,*)'tracers ', nqold+1,' to ', nqmx,'are new'
+             yes=' '
+            do while ((yes.ne.'y').and.(yes.ne.'n'))
+             write(*,*) 'Would you like to reindex tracer # 1 ->',nqold
+             write(*,*) 'to #',nqmx-nqold+1,'->', nqmx,'   (y or n) ?'
+             read(*,fmt='(a)') yes
+            end do
+            if (yes.eq.'y') then
+              write(*,*) 'OK, let s reindex the tracers'
+              do l=1,llm
+                do j=1,jjp1
+                  do i=1,iip1
+                    do iq=nqmx,nqmx-nqold+1,-1
+                       q(i,j,l,iq)=q(i,j,l,iq-nqmx+nqold)   
+                    end do
+                    do iq=nqmx-nqold,1,-1
+                       q(i,j,l,iq)= 0.
+                    end do
+                  end do
+                end do
+              end do
+            end if 
+         end if
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynredem.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynredem.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/dynredem.F	(revision 57)
@@ -0,0 +1,694 @@
+      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_llm, idim_llmp1
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+
+      REAL zan0,zjulian,hours
+      REAL sigs(llm)
+      INTEGER yyears0,jjour0, mmois0
+      character*30 unites
+
+
+c-----------------------------------------------------------------------
+      modname='dynredem'
+      do l=1,llm
+         sigs(l)=float(l)
+      enddo
+
+      DO l=1,length
+       tab_cntrl(l) = 0.
+      ENDDO
+       tab_cntrl(1)  = FLOAT(iim)
+       tab_cntrl(2)  = FLOAT(jjm)
+       tab_cntrl(3)  = FLOAT(llm)
+       tab_cntrl(4)  = FLOAT(idayref)
+       tab_cntrl(5)  = rad
+       tab_cntrl(6)  = omeg
+       tab_cntrl(7)  = g
+       tab_cntrl(8)  = 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
+c
+c    .....    parametres  pour le zoom      ......   
+
+       tab_cntrl(19)  = clon
+       tab_cntrl(20)  = clat
+       tab_cntrl(21)  = grossismx
+       tab_cntrl(22)  = grossismy
+c
+      IF ( fxyhypb )   THEN
+       tab_cntrl(23) = 1.
+       tab_cntrl(24) = dzoomx
+       tab_cntrl(25) = dzoomy
+       tab_cntrl(26) = 0.
+       tab_cntrl(27) = taux
+       tab_cntrl(28) = tauy
+      ELSE
+       tab_cntrl(23) = 0.
+       tab_cntrl(24) = dzoomx
+       tab_cntrl(25) = dzoomy
+       tab_cntrl(26) = 0.
+       tab_cntrl(27) = 0.
+       tab_cntrl(28) = 0.
+       IF( ysinus )  tab_cntrl(26) = 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",18,
+     .                       "Dynamic start file")
+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, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid, "interlayer", llmp1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_tim)
+
+c     CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret:
+c     ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+c     ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+c     ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+c
+c Definir et enregistrer certains champs invariants:
+c
+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
+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
+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
+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
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 30,
+     .          "Coef A: hybrid pressure levels"  )
+      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
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 27,
+     .      "Coef B: hybrid sigma levels")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 37,
+     .      "Coef AS: hybrid pressure in midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 31,
+     .      "Coef BS: hybrid sigma midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c ------------------------------------------------------------------
+c ------------------------------------------------------------------
+c  Variable uniquement pour visualisation avec Grads ou Ferret
+c ------------------------------------------------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1,
+     .       idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1,
+     .       idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+  
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif
+  
+  
+c ----------------------
+c ----------------------
+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
+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 ----------------------
+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 ----------------------
+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 ----------------------
+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,"Time",NF_DOUBLE,1,idim_tim,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"Time",NF_FLOAT,1,idim_tim,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Temps de simulation")
+      write(unites,200)yyears0,mmois0,jjour0
+200   format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00')
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30,
+     .                         unites)
+
+c
+      dims4(1) = idim_rlonu
+      dims4(2) = idim_rlatu
+      dims4(3) = idim_llm
+      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_llm
+      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_llm
+      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_llm
+      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_llm
+      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
+
+c ================================================================
+      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(iip1,jjp1,llm,nqmx)
+      REAL q3d(iip1,jjp1,llm) !temporary variable
+      CHARACTER*(*) fichnom
+     
+      REAL time
+      INTEGER nid, nvarid
+      INTEGER ierr
+      INTEGER iq
+      CHARACTER str3*3
+      character*20 modname
+      character*80 abort_message
+c
+      INTEGER nb,i,j
+      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, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         print *, NF_STRERROR(ierr)
+         abort_message='Variable Time 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.GT.99) THEN
+         PRINT*, "Trop de traceurs"
+         CALL abort
+      ENDIF
+      IF(nq.GE.1) THEN
+         DO iq=1,nq
+            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
+            do l=1,llm
+               do j=1,jjp1
+                  do i=1,iip1
+                     q3d(i,j,l)=q(i,j,l,iq)
+                  enddo
+               enddo
+            enddo
+#ifdef NC_DOUBLE
+            ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q3d)
+#else
+            ierr = NF_PUT_VAR_REAL (nid,nvarid,q3d)
+#endif
+            IF (ierr .NE. NF_NOERR) THEN
+               PRINT*, "Error: ", NF_STRERROR(ierr)
+               CALL abort
+            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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ener.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ener.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ener.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/enercin.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/enercin.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/enercin.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner.F	(revision 57)
@@ -0,0 +1,29 @@
+      SUBROUTINE exner(ngrid,pext,aire,pks,pksf)
+      IMPLICIT NONE
+
+c      .........    Version du 16/04/96     .........
+c
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "comconst.h"
+
+      INTEGER ngrid
+      REAL pext(ngrid),aire(ngrid),pks(ngrid),pksf(ngrid)
+
+      INTEGER ig,iii
+
+      EXTERNAL filtreg
+
+c-----------------------------------------------------------------------
+
+      DO 3 ig = 1,ngrid
+         pks( ig )     = ( pext( ig )/ aire( ig ) ) ** kappa
+         pksf( ig )    = pks( ig )
+   3  CONTINUE
+
+      CALL filtreg (pksf,jmp1,1,2,1,.true.,1)
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exnerF
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exnerF	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exnerF	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner_hyb.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner_hyb.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/exner_hyb.F	(revision 57)
@@ -0,0 +1,102 @@
+      SUBROUTINE  exner_hyb ( ngrid, ps, p,beta, pks, pk, pkf )
+c
+c     Auteurs :  F. Forget , Y. Wanherdrick
+c P.Le Van  , Fr. Hourdin  .
+c    ..........
+c
+c    ....  ngrid, ps,p             sont des argum.d'entree  au sous-prog ...
+c    .... beta, pks,pk,pkf   sont des argum.de sortie au sous-prog ...
+c
+c   ************************************************************************
+c    Calcule la fonction d'Exner pk = Cp * (p/preff) ** 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     WARNING : CECI est une version speciale de exner_hyb originale
+c               Utilis dans la version martienne pour pouvoir 
+c               tourner avec des coordonnes verticales complexe
+c              => Il ne verifie PAS la condition la proportionalit en 
+c              nergie totale/ interne / potentielle (F.Forget 2001)
+c    ( voir note de Fr.Hourdin )  ,
+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), beta(ngrid,llm)
+
+c    .... variables locales   ...
+
+      INTEGER l, ij
+      REAL dum1
+
+      REAL ppn(iim),pps(iim)
+      REAL xpn, xps
+      REAL SSUM
+      EXTERNAL filtreg, SSUM
+      
+c     -------------
+c     Calcul de pks
+c     -------------
+   
+      DO   ij  = 1, ngrid
+        pks(ij) = cpp * ( ps(ij)/preff ) ** kappa
+      ENDDO
+
+      DO  ij   = 1, iim
+        ppn(ij) = aire(   ij   ) * pks(  ij     )
+        pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm )
+      ENDDO
+      xpn      = SSUM(iim,ppn,1) /apoln
+      xps      = SSUM(iim,pps,1) /apols
+
+      DO ij   = 1, iip1
+        pks(   ij     )  =  xpn
+        pks( ij+ip1jm )  =  xps
+      ENDDO
+c
+c
+c    .... Calcul de pk  pour la couche l 
+c    --------------------------------------------
+c
+      dum1 = cpp * (2*preff)**(-kappa) 
+      DO l = 1, llm-1
+        DO   ij   = 1, ngrid
+         pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa
+        ENDDO
+      ENDDO
+
+c    .... Calcul de pk  pour la couche l = llm ..
+c    (on met la meme distance (en log pression)  entre Pk(llm)
+c    et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2)
+
+      DO   ij   = 1, ngrid
+         pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)
+      ENDDO
+
+
+c    calcul de pkf
+c    -------------
+      CALL SCOPY   ( ngrid * llm, pk, 1, pkf, 1 )
+      CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 )
+      
+c    EST-CE UTILE ?? : calcul de beta
+c    --------------------------------
+      DO l = 2, llm
+        DO   ij   = 1, ngrid
+          beta(ij,l) = pk(ij,l) / pk(ij,l-1)   
+        ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/flumass.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/flumass.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/flumass.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fluxstoke.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fluxstoke.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fluxstoke.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxhyp.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxhyp.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxhyp.F	(revision 57)
@@ -0,0 +1,448 @@
+       SUBROUTINE fxhyp ( xzoomdeg,grossism,dzoom,tau ,
+     , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025,
+     , champmin,champmax                                               )
+
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+c    Calcule les longitudes et derivees dans la grille du GCM pour une
+c     fonction f(x) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.)
+c     dzoom  etant  la distance totale de la zone du zoom
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom
+c
+c    On doit avoir grossism x dzoom <  pi ( radians )   , en longitude.
+c   ********************************************************************
+
+
+       INTEGER nmax, nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+       LOGICAL scal180
+       PARAMETER ( scal180 = .TRUE. )
+
+c      scal180 = .TRUE.  si on veut avoir le premier point scalaire pour   
+c      une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres.
+c      sinon scal180 = .FALSE.
+
+#include "dimensions.h"
+#include "paramet.h"
+       
+c     ......  arguments  d'entree   .......
+c
+       REAL xzoomdeg,dzoom,tau,grossism
+
+c    ......   arguments  de  sortie  ......
+
+       REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1),
+     ,  rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1)
+
+c     .... variables locales  ....
+c
+       REAL*8 xlon(iip1),xprimm(iip1),xuv
+       REAL*8 xtild(0:nmax2)
+       REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2)
+       REAL*8 Xf(0:nmax2),xxpr(0:nmax2)
+       REAL*8 xvrai(iip1),xxprim(iip1) 
+       REAL*8 pi,depi,epsilon,xzoom,fa,fb
+       REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2
+       INTEGER i,it,ik,iter,ii,idif,ii1,ii2
+       REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin
+       REAL*8 champmin,champmax,decalx
+       INTEGER is2
+       SAVE is2
+
+       REAL*8 heavyside
+       EXTERNAL coefpoly,heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       epsilon  = 1.e-3
+       xzoom    = xzoomdeg * pi/180. 
+c
+           decalx   = .75
+       IF( grossism.EQ.1..AND.scal180 )  THEN
+           decalx   = 1.
+       ENDIF
+
+       WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx
+c
+       IF( dzoom.LT.1.)  THEN
+         dzoom = dzoom * depi
+       ELSEIF( dzoom.LT. 25. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fxhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzoom * pi/180.
+       ENDIF
+
+       WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) xzoom,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        xtild(i) = - pi + FLOAT(i) * depi /nmax2
+       ENDDO
+
+       DO i = nmax, nmax2
+
+       fa  = tau*  ( dzoom/2.  - xtild(i) )
+       fb  = xtild(i) *  ( pi - xtild(i) )
+
+         IF( 200.* fb .LT. - fa )   THEN
+           fhyp ( i) = - 1.
+         ELSEIF( 200. * fb .LT. fa ) THEN
+           fhyp ( i) =   1.
+         ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fhyp ( i ) = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fhyp ( i )  =   1.
+                ENDIF
+            ELSE
+                    fhyp ( i )  =  TANH ( fa/fb )
+            ENDIF
+         ENDIF
+
+        IF ( xtild(i).EQ. 0. )  fhyp(i) =  1.
+        IF ( xtild(i).EQ. pi )  fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c   ............................
+
+       ffdx = 0.
+
+       DO i = nmax +1,nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+            IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13)  THEN
+                IF(   200.*fb + fa.LT.1.e-10 )  THEN
+                    fxm   = - 1.
+                ELSEIF( 200.*fb - fa.LT.1.e-10 )  THEN
+                    fxm   =   1.
+                ENDIF
+            ELSE
+                    fxm   =  TANH ( fa/fb )
+            ENDIF
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm  =  1.
+       IF ( xmoy.EQ. pi )  fxm  = -1.
+
+       ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) )
+
+       ENDDO
+
+        beta  = ( grossism * ffdx - pi ) / ( ffdx - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fxhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismx ,tau ou dzoomx ',
+     , ' et relancer ! ***  '
+        CALL ABORT
+       ENDIF
+c
+c   .....  calcul  de  Xprimt   .....
+c
+       
+       DO i = nmax, nmax2
+        Xprimt(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+c   
+       DO i =  nmax+1, nmax2
+        Xprimt( nmax2 - i ) = Xprimt( i )
+       ENDDO
+c
+
+c   .....  Calcul  de  Xf     ........
+
+       Xf(0) = - pi
+
+       DO i =  nmax +1, nmax2
+
+       xmoy    = 0.5 * ( xtild(i-1) + xtild( i ) )
+       fa  = tau*  ( dzoom/2.  - xmoy )
+       fb  = xmoy *  ( pi - xmoy )
+
+       IF( 200.* fb .LT. - fa )   THEN
+         fxm = - 1.
+       ELSEIF( 200. * fb .LT. fa ) THEN
+         fxm =   1.
+       ELSE
+         fxm =  TANH ( fa/fb )
+       ENDIF
+
+       IF ( xmoy.EQ. 0. )  fxm =  1.
+       IF ( xmoy.EQ. pi )  fxm = -1.
+       xxpr(i)    = beta + ( grossism - beta ) * fxm
+
+       ENDDO
+
+       DO i = nmax+1, nmax2
+        xxpr(nmax2-i+1) = xxpr(i)
+       ENDDO
+
+        DO i=1,nmax2
+         Xf(i)   = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) )
+        ENDDO
+
+
+c    *****************************************************************
+c
+
+c     .....  xuv = 0.   si  calcul  aux pts   scalaires   ........
+c     .....  xuv = 0.5  si  calcul  aux pts      U        ........
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1, 4
+
+       IF( ik.EQ.1 )        THEN
+         xuv =  -0.25
+       ELSE IF ( ik.EQ.2 )  THEN
+         xuv =   0.
+       ELSE IF ( ik.EQ.3 )  THEN
+         xuv =   0.50
+       ELSE IF ( ik.EQ.4 )  THEN
+         xuv =   0.25
+       ENDIF
+
+      xo1   = 0.
+
+      ii1=1
+      ii2=iim
+      IF(ik.EQ.1.and.grossism.EQ.1.) THEN
+        ii1 = 2 
+        ii2 = iim+1
+      ENDIF
+
+      DO 1500 i = ii1, ii2
+
+      xlon2 = - pi + (FLOAT(i) + xuv - decalx) * depi / FLOAT(iim) 
+
+      Xfi    = xlon2
+c
+      DO 250 it =  nmax2,0,-1
+      IF( Xfi.GE.Xf(it))  GO TO 350
+250   CONTINUE
+
+      it = 0
+
+350   CONTINUE
+
+c    ......  Calcul de   Xf(xi)    ...... 
+c
+      xi  = xtild(it)
+
+      IF(it.EQ.nmax2)  THEN
+       it       = nmax2 -1
+       Xf(it+1) = pi
+      ENDIF
+c  .....................................................................
+c
+c   Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un
+c   polynome de degre 3  qui passe  par les points (Xf(it),xtild(it) )
+c          et (Xf(it+1),xtild(it+1) )
+
+       CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1),
+     ,                xtild(it),xtild(it+1),  a0, a1, a2, a3  )
+
+       Xf1     = Xf(it)
+       Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi
+
+       DO 500 iter = 1,300
+        xi = xi - ( Xf1 - Xfi )/ Xprimin
+
+        IF( ABS(xi-xo1).LE.epsilon)  GO TO 550
+         xo1      = xi
+         xi2      = xi * xi
+         Xf1      = a0 +  a1 * xi +     a2 * xi2  +     a3 * xi2 * xi
+         Xprimin  =       a1      + 2.* a2 *  xi  + 3.* a3 * xi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter
+          STOP 6
+550   CONTINUE
+
+       xxprim(i) = depi/ ( FLOAT(iim) * Xprimin )
+       xvrai(i)  =  xi + xzoom
+
+1500   CONTINUE
+
+
+       IF(ik.EQ.1.and.grossism.EQ.1.)  THEN
+         xvrai(1)    = xvrai(iip1)-depi
+         xxprim(1)   = xxprim(iip1)
+       ENDIF
+       DO i = 1 , iim
+        xlon(i)     = xvrai(i)
+        xprimm(i)   = xxprim(i)
+       ENDDO
+  
+       DO i = 1, iim -1
+        IF( xvrai(i+1). LT. xvrai(i) )  THEN
+         WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i,
+     ,  ')'
+        STOP 7
+        ENDIF
+       ENDDO
+c
+c   ... Reorganisation  des  longitudes  pour les avoir  entre - pi et pi ..
+c   ........................................................................
+
+       champmin =  1.e12
+       champmax = -1.e12
+       DO i = 1, iim
+        champmin = MIN( champmin,xvrai(i) )
+        champmax = MAX( champmax,xvrai(i) )
+       ENDDO
+
+      IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 )  THEN
+                GO TO 1600
+      ELSE
+       WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi',
+     ,  ' et pi '
+c
+        IF( xzoom.LE.0.)  THEN
+          IF( ik.EQ. 1 )  THEN
+          DO i = 1, iim
+           IF( xvrai(i).GE. - pi )  GO TO 80
+          ENDDO
+            WRITE(6,*)  ' PBS. 1 !  Xvrai plus petit que  - pi ! '
+            STOP 8
+ 80       CONTINUE
+          is2 = i
+          ENDIF
+
+          IF( is2.NE. 1 )  THEN
+            DO ii = is2 , iim
+             xlon  (ii-is2+1) = xvrai(ii)
+             xprimm(ii-is2+1) = xxprim(ii)
+            ENDDO
+            DO ii = 1 , is2 -1
+             xlon  (ii+iim-is2+1) = xvrai(ii) + depi
+             xprimm(ii+iim-is2+1) = xxprim(ii) 
+            ENDDO
+          ENDIF
+        ELSE 
+          IF( ik.EQ.1 )  THEN
+           DO i = iim,1,-1
+             IF( xvrai(i).LE. pi ) GO TO 90
+           ENDDO
+             WRITE(6,*) ' PBS.  2 ! Xvrai plus grand  que   pi ! '
+              STOP 9
+ 90        CONTINUE
+            is2 = i
+          ENDIF
+           idif = iim -is2
+           DO ii = 1, is2
+            xlon  (ii+idif) = xvrai(ii)
+            xprimm(ii+idif) = xxprim(ii)
+           ENDDO
+           DO ii = 1, idif
+            xlon (ii)  = xvrai (ii+is2) - depi
+            xprimm(ii) = xxprim(ii+is2) 
+           ENDDO
+         ENDIF
+      ENDIF
+c
+c     .........   Fin  de la reorganisation   ............................
+
+ 1600    CONTINUE
+
+
+         xlon  ( iip1)  = xlon(1) + depi
+         xprimm( iip1 ) = xprimm (1 )
+       
+         DO i = 1, iim+1
+         xvrai(i) = xlon(i)*180./pi
+         ENDDO
+
+         IF( ik.EQ.1 )  THEN
+c          WRITE(6,*)  ' XLON aux pts. V-0.25   apres ( en  deg. ) '
+c          WRITE(6,18) 
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim +1
+             rlonm025(i) = xlon( i )
+            xprimm025(i) = xprimm(i)
+           ENDDO
+           
+         ELSE IF( ik.EQ.2 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM k ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonv(i) = xlon( i )
+            xprimv(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.3)   THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. U   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonu(i) = xlon( i )
+            xprimu(i) = xprimm(i)
+           ENDDO
+
+         ELSE IF( ik.EQ.4 )  THEN
+c          WRITE(6,18) 
+c          WRITE(6,*)  ' XLON aux pts. V+0.25   apres ( en  deg. ) '
+c          WRITE(6,68) xvrai
+c          WRITE(6,*) ' XPRIM ik ',ik
+c          WRITE(6,566)  xprimm
+
+           DO i = 1,iim + 1
+             rlonp025(i) = xlon( i )
+            xprimp025(i) = xprimm(i)
+           ENDDO
+
+         ENDIF
+
+5000    CONTINUE
+c
+       WRITE(6,18)
+c
+c    ...........  fin  de la boucle  do 5000      ............
+
+        DO i = 1, iim
+         xlon(i) = rlonv(i+1) - rlonv(i)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO i = 1, iim
+         champmin = MIN( champmin, xlon(i) )
+         champmax = MAX( champmax, xlon(i) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+18     FORMAT(/)
+24     FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3)
+68     FORMAT(1x,7f9.2)
+566    FORMAT(1x,7f9.4)
+
+       RETURN
+       END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxy.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxy.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxy.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxyhyper.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxyhyper.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxyhyper.F	(revision 57)
@@ -0,0 +1,137 @@
+c
+c $Header: /users/lmdz/cvsroot/LMDZ.3.3/libf/dyn3d/fxyhyper.F,v 1.4 2001/04/24 13:12:44 lmdz Exp $
+c
+       SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy  ,   
+     ,                       xzoom, grossx, dzoomx,taux  ,
+     , rlatu,yprimu,rlatv,yprimv,rlatu1,  yprimu1,  rlatu2,  yprimu2  , 
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       IMPLICIT NONE
+c
+c      Auteur :  P. Le Van .
+c
+c      d'apres  formulations de R. Sadourny .
+c
+c
+c     Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp )
+c            par des  fonctions  a tangente hyperbolique .
+c
+c     Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom
+c                      et  yzoom )   :  
+c
+c     a) le grossissement du zoom  :  grossy  ( en y ) et grossx ( en x )
+c     b) l' extension     du zoom  :  dzoomy  ( en y ) et dzoomx ( en x )
+c     c) la raideur de la transition du zoom  :   taux et tauy   
+c
+c  N.B : Il vaut mieux avoir   :   grossx * dzoomx <  pi    ( radians )
+c ******
+c                  et              grossy * dzoomy <  pi/2  ( radians )
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+
+c   .....  Arguments  ...
+c
+       REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy
+       REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+       REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1),
+     , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1)
+       REAL*8  dxmin, dxmax , dymin, dymax
+
+c   ....   var. locales   .....
+c
+       INTEGER i,j
+c
+
+       CALL fyhyp ( yzoom, grossy, dzoomy,tauy  , 
+     ,  rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  dymin,dymax                                               )
+
+       CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv,
+     , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax         )
+
+
+        DO i = 1, iip1
+          IF(rlonp025(i).LT.rlonv(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 < rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonv(i).LT.rlonm025(i))  THEN 
+           WRITE(6,*) ' Attention !  rlonm025 > rlonv',i
+            STOP
+          ENDIF
+
+          IF(rlonp025(i).GT.rlonu(i))  THEN
+           WRITE(6,*) ' Attention !  rlonp025 > rlonu',i
+            STOP
+          ENDIF
+        ENDDO
+
+        WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FX **** '
+
+c
+       DO j = 1, jjm
+c
+       IF(rlatu1(j).LE.rlatu2(j))   THEN
+         WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j
+         STOP 13
+       ENDIF
+c
+       IF(rlatu2(j).LE.rlatu(j+1))  THEN
+        WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j
+        STOP 14
+       ENDIF
+c
+       IF(rlatu(j).LE.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j
+        STOP 15
+       ENDIF
+c
+       IF(rlatv(j).LE.rlatu2(j))    THEN
+        WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j
+        STOP 16
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu1(j))    THEN
+        WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j
+        STOP 17
+       ENDIF
+c
+       IF(rlatv(j).ge.rlatu(j))     THEN
+        WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j
+        STOP 18
+       ENDIF
+c
+       ENDDO
+c
+       WRITE(6,*) '  *** TEST DE COHERENCE  OK    POUR   FY **** '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Latitudes  '
+        WRITE(6,*) ' *********** '
+        WRITE(6,18)
+        WRITE(6,3)  dymin, dymax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+c
+        WRITE(6,18)
+        WRITE(6,*) '  Longitudes  '
+        WRITE(6,*) ' ************ '
+        WRITE(6,18)
+        WRITE(6,3)  dxmin, dxmax
+        WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par
+     ,ametres  grossism , tau , dzoom pour Y et repasser ! '
+        WRITE(6,18)
+c
+3      Format(1x, ' Au centre du zoom , la longueur de la maille est',
+     ,  ' d environ ',f8.2 ,' degres  ',
+     , ' alors que la maille en dehors de la zone du zoom est d environ
+     , ', f8.2,' degres ' )
+18      FORMAT(/)
+
+       RETURN
+       END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxysinus.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxysinus.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fxysinus.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fyhyp.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fyhyp.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/fyhyp.F	(revision 57)
@@ -0,0 +1,376 @@
+C
+c $Header: /users/lmdz/cvsroot/LMDZ.3.3/libf/dyn3d/fyhyp.F,v 1.5 2001/07/04 10:46:06 lmdz Exp $
+c
+       SUBROUTINE fyhyp ( yzoomdeg, grossism, dzoom,tau  ,  
+     ,  rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 ,
+     ,  champmin,champmax                                            ) 
+
+cc    ...  Version du 01/04/2001 ....
+
+       IMPLICIT NONE
+c
+c    ...   Auteur :  P. Le Van  ... 
+c
+c    .......    d'apres  formulations  de R. Sadourny  .......
+c
+c     Calcule les latitudes et derivees dans la grille du GCM pour une
+c     fonction f(y) a tangente  hyperbolique  .
+c
+c     grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc)
+c     dzoom  etant  la distance totale de la zone du zoom ( en radians )
+c     tau  la raideur de la transition de l'interieur a l'exterieur du zoom   
+c
+c
+c N.B : Il vaut mieux avoir : grossism * dzoom  <  pi/2  (radians) ,en lati.
+c      ********************************************************************
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+
+       INTEGER      nmax , nmax2
+       PARAMETER (  nmax = 30000, nmax2 = 2*nmax )
+c
+c
+c     .......  arguments  d'entree    .......
+c
+       REAL yzoomdeg, grossism,dzoom,tau 
+c         ( rentres  par  run.def )
+
+c     .......  arguments  de sortie   .......
+c
+       REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm),
+     , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm)
+
+c
+c     .....     champs  locaux    .....
+c
+     
+       REAL*8 ylat(jjp1), yprim(jjp1)
+       REAL*8 yuv
+       REAL*8 yt(0:nmax2)
+       REAL*8 fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2)
+       SAVE Ytprim, yt,Yf
+       REAL*8 Yf(0:nmax2),yypr(0:nmax2)
+       REAL*8 yvrai(jjp1), yprimm(jjp1),ylatt(jjp1)
+       REAL*8 pi,depi,pis2,epsilon,y0,pisjm
+       REAL*8 yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax
+       REAL*8 yfi,Yf1,ffdy
+       REAL*8 ypn,deply,y00
+       SAVE y00, deply
+
+       INTEGER i,j,it,ik,iter,jlat
+       INTEGER jpn,jjpn
+       SAVE jpn
+       REAL*8 a0,a1,a2,a3,yi2,heavyy0,heavyy0m
+       REAL*8 fa(0:nmax2),fb(0:nmax2)
+       REAL y0min,y0max
+
+       REAL*8     heavyside
+       EXTERNAL   heavyside
+
+       pi       = 2. * ASIN(1.)
+       depi     = 2. * pi
+       pis2     = pi/2.
+       pisjm    = pi/ FLOAT(jjm)
+       epsilon  = 1.e-3
+       y0       =  yzoomdeg * pi/180. 
+
+       IF( dzoom.LT.1.)  THEN
+         dzoom = dzoom * pi
+       ELSEIF( dzoom.LT. 12. ) THEN
+         WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug
+     ,menter et relancer ! '
+         STOP 1
+       ELSE
+         dzoom = dzoom * pi/180.
+       ENDIF
+
+       WRITE(6,18)
+       WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)'
+       WRITE(6,24) y0,grossism,tau,dzoom
+
+       DO i = 0, nmax2 
+        yt(i) = - pis2  + FLOAT(i)* pi /nmax2
+       ENDDO
+
+       heavyy0m = heavyside( -y0 )
+       heavyy0  = heavyside(  y0 )
+       y0min    = 2.*y0*heavyy0m - pis2
+       y0max    = 2.*y0*heavyy0  + pis2
+
+       fa = 999.999
+       fb = 999.999
+
+       DO i = 0, nmax2 
+        IF( yt(i).LT.y0 )  THEN
+         fa (i) = tau*  (yt(i)-y0+dzoom/2. )
+         fb(i) =   (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) )
+        ELSEIF ( yt(i).GT.y0 )  THEN
+         fa(i) =   tau *(y0-yt(i)+dzoom/2. )
+         fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) 
+       ENDIF
+        
+       IF( 200.* fb(i) .LT. - fa(i) )   THEN
+         fhyp ( i) = - 1.
+       ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fhyp ( i) =   1.
+       ELSE  
+         fhyp(i) =  TANH ( fa(i)/fb(i) )
+       ENDIF
+
+       IF( yt(i).EQ.y0 )  fhyp(i) = 1.
+       IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1.
+
+       ENDDO
+
+cc  ....  Calcul  de  beta  ....
+c
+       ffdy   = 0.
+
+       DO i = 1, nmax2
+        ymoy    = 0.5 * ( yt(i-1) + yt( i ) )
+        IF( ymoy.LT.y0 )  THEN
+         fa(i)= tau * ( ymoy-y0+dzoom/2.) 
+         fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy )
+        ELSEIF ( ymoy.GT.y0 )  THEN
+         fa(i)= tau * ( y0-ymoy+dzoom/2. ) 
+         fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 )
+        ENDIF
+
+        IF( 200.* fb(i) .LT. - fa(i) )    THEN
+         fxm ( i) = - 1.
+        ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN
+         fxm ( i) =   1.
+        ELSE
+         fxm(i) =  TANH ( fa(i)/fb(i) )
+        ENDIF
+         IF( ymoy.EQ.y0 )  fxm(i) = 1.
+         IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1.
+         ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) )
+
+        ENDDO
+
+        beta  = ( grossism * ffdy - pi ) / ( ffdy - pi )
+
+       IF( 2.*beta - grossism.LE. 0.)  THEN
+
+        WRITE(6,*) ' **  Attention ! La valeur beta calculee dans la rou
+     ,tine fyhyp est mauvaise ! '
+        WRITE(6,*)'Modifier les valeurs de  grossismy ,tauy ou dzoomy',
+     , ' et relancer ! ***  '
+        CALL ABORT
+
+       ENDIF
+c
+c   .....  calcul  de  Ytprim   .....
+c
+       
+       DO i = 0, nmax2
+        Ytprim(i) = beta  + ( grossism - beta ) * fhyp(i)
+       ENDDO
+
+c   .....  Calcul  de  Yf     ........
+
+       Yf(0) = - pis2
+       DO i = 1, nmax2
+        yypr(i)    = beta + ( grossism - beta ) * fxm(i)
+       ENDDO
+
+       DO i=1,nmax2
+        Yf(i)   = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) )
+       ENDDO
+
+c    ****************************************************************
+c
+c   .....   yuv  = 0.   si calcul des latitudes  aux pts.  U  .....
+c   .....   yuv  = 0.5  si calcul des latitudes  aux pts.  V  .....
+c
+      WRITE(6,18)
+c
+      DO 5000  ik = 1,4
+
+       IF( ik.EQ.1 )  THEN
+         yuv  = 0.
+         jlat = jjm + 1
+       ELSE IF ( ik.EQ.2 )  THEN
+         yuv  = 0.5
+         jlat = jjm 
+       ELSE IF ( ik.EQ.3 )  THEN
+         yuv  = 0.25
+         jlat = jjm 
+       ELSE IF ( ik.EQ.4 )  THEN
+         yuv  = 0.75
+         jlat = jjm 
+       ENDIF
+c
+       yo1   = 0.
+       DO 1500 j =  1,jlat
+        yo1   = 0.
+        ylon2 =  - pis2 + pisjm * ( FLOAT(j)  + yuv  -1.)  
+        yfi    = ylon2
+c
+       DO 250 it =  nmax2,0,-1
+        IF( yfi.GE.Yf(it))  GO TO 350
+250    CONTINUE
+       it = 0
+350    CONTINUE
+
+       yi = yt(it)
+       IF(it.EQ.nmax2)  THEN
+        it       = nmax2 -1
+        Yf(it+1) = pis2
+       ENDIF
+c  .................................................................
+c  ....  Interpolation entre  yi(it) et yi(it+1)   pour avoir Y(yi)  
+c      .....           et   Y'(yi)                             .....
+c  .................................................................
+
+       CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1),   
+     ,                  yt(it),yt(it+1) ,   a0,a1,a2,a3   )      
+
+       Yf1     = Yf(it)
+       Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi
+
+       DO 500 iter = 1,300
+         yi = yi - ( Yf1 - yfi )/ Yprimin
+
+        IF( ABS(yi-yo1).LE.epsilon)  GO TO 550
+         yo1      = yi
+         yi2      = yi * yi
+         Yf1      = a0 +  a1 * yi +     a2 * yi2  +     a3 * yi2 * yi
+         Yprimin  =       a1      + 2.* a2 *  yi  + 3.* a3 * yi2
+500   CONTINUE
+        WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter
+         STOP 2
+550   CONTINUE
+c
+       Yprimin   = a1  + 2.* a2 *  yi   + 3.* a3 * yi* yi
+       yprim(j)  = pi / ( jjm * Yprimin )
+       yvrai(j)  = yi 
+
+1500    CONTINUE
+
+       DO j = 1, jlat -1
+        IF( yvrai(j+1). LT. yvrai(j) )  THEN
+         WRITE(6,*) ' PBS. avec  rlat(',j+1,') plus petit que rlat(',j,
+     ,  ')'
+         STOP 3
+        ENDIF
+       ENDDO
+
+       WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2'
+     , ,' et  pi/2 '
+c
+        IF( ik.EQ.1 )   THEN
+           ypn = pis2 
+          DO j = jlat,1,-1
+           IF( yvrai(j).LE. ypn ) GO TO 1502
+          ENDDO
+1502     CONTINUE
+
+         jpn   = j
+         y00   = yvrai(jpn)
+         deply = pis2 -  y00
+        ENDIF
+
+         DO  j = 1, jjm +1 - jpn
+           ylatt (j)  = -pis2 - y00  + yvrai(jpn+j-1)
+           yprimm(j)  = yprim(jpn+j-1)
+         ENDDO
+
+         jjpn  = jpn
+         IF( jlat.EQ. jjm ) jjpn = jpn -1
+
+         DO j = 1,jjpn 
+          ylatt (j + jjm+1 -jpn) = yvrai(j) + deply
+          yprimm(j + jjm+1 -jpn) = yprim(j)
+         ENDDO
+
+c      ***********   Fin de la reorganisation     *************
+c
+ 1600   CONTINUE
+
+       DO j = 1, jlat
+          ylat(j) =  ylatt( jlat +1 -j )
+         yprim(j) = yprimm( jlat +1 -j )
+       ENDDO
+  
+        DO j = 1, jlat
+         yvrai(j) = ylat(j)*180./pi
+        ENDDO
+
+        IF( ik.EQ.1 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U   apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatu(j) =  ylat( j )
+           yyprimu(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 2 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*) ' YLAT   en V  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*)' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rrlatv(j) =  ylat( j )
+           yyprimv(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 3 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT  en U + 0.75  apres ( en  deg. ) '
+c         WRITE(6,68) (yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,445) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu2(j) =  ylat( j )
+           yprimu2(j) = yprim( j )
+          ENDDO
+
+        ELSE IF ( ik.EQ. 4 )  THEN
+c         WRITE(6,18) 
+c         WRITE(6,*)  ' YLAT en U + 0.25  apres ( en  deg. ) '
+c         WRITE(6,68)(yvrai(j),j=1,jlat)
+cc         WRITE(6,*) ' YPRIM '
+cc         WRITE(6,68) ( yprim(j),j=1,jlat)
+
+          DO j = 1, jlat
+            rlatu1(j) =  ylat( j )
+           yprimu1(j) = yprim( j )
+          ENDDO
+
+        ENDIF
+
+5000   CONTINUE
+c
+        WRITE(6,18)
+c
+c  .....     fin de la boucle  do 5000 .....
+
+        DO j = 1, jjm
+         ylat(j) = rrlatu(j) - rrlatu(j+1)
+        ENDDO
+        champmin =  1.e12
+        champmax = -1.e12
+        DO j = 1, jjm
+         champmin = MIN( champmin, ylat(j) )
+         champmax = MAX( champmax, ylat(j) )
+        ENDDO
+         champmin = champmin * 180./pi
+         champmax = champmax * 180./pi
+
+24     FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3)
+18      FORMAT(/)
+68      FORMAT(1x,7f9.2)
+
+        RETURN
+        END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gcm.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gcm.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gcm.F	(revision 57)
@@ -0,0 +1,676 @@
+      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
+c  ... Dans inigeom , nouveaux calculs pour les elongations  cu , cv
+c      et possibilite d'appeler une fonction f(y)  a derivee tangente
+c      hyperbolique a la  place de la fonction a derivee sinusoidale.
+
+c  ... Possibilite de choisir le shema de Van-leer pour l'advection de
+c        q  , en faisant iadv = 3  dans   traceur  (29/04/97) .
+c
+c      Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99)
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissnew.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include "tracstoke.h"
+#include "sponge.h"
+
+
+      INTEGER*4  iday ! jour julien
+      REAL       time ! Heure de la journee en fraction d''1 jour
+      REAL zdtvr
+
+c   variables dynamiques
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      real, dimension(ip1jmp1,llm) :: teta   ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL ps(ip1jmp1)                       ! pression  au sol
+      REAL pext(ip1jmp1)                     ! pression  extensive
+      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,l,ierr,numvanle,iapp_tracvl
+
+      REAL rdayvrai,rdaym_ini,rday_ecri
+      LOGICAL first
+      REAL beta(ip1jmp1,llm)
+
+      LOGICAL offline  ! Controle du stockage ds "fluxmass"
+      PARAMETER (offline=.false.)
+
+      character*20 modname
+      character*80 abort_message
+
+      LOGICAL tracer
+	  data tracer/.true./
+
+C Calendrier
+      LOGICAL true_calendar
+      PARAMETER (true_calendar = .false.)
+
+! flag to set/remove calls to groupeun
+      logical callgroupeun
+      parameter (callgroupeun = .true.)
+c-----------------------------------------------------------------------
+c   Initialisations:
+c   ----------------
+
+      modname = 'gcm'
+      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     iadv = 4    schema  Van-leer + humidite specifique
+c                        Modif F.Codron
+c 
+c     dans le tableau q(ij,l,iq) , iq = 1  pour l'eau vapeur
+c                                , iq = 2  pour l'eau liquide
+c         et eventuellement      , iq = 3, nqmx pour les autres traceurs
+c
+c     iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+c
+c  !!!!!Mars: vapeur d'eau = traceur nqmx !!!!!
+c
+      DO iq = 1, nqmx
+       iadv( iq ) = 3    ! Van-Leer + humidite pas au point? (Yann)
+      ENDDO
+c
+      DO  iq = 1, nqmx-1
+       IF( iadv(iq).EQ.1 ) PRINT *,' Choix du shema humidite specifique'
+     * ,' pour le traceur no ', iq
+       IF( iadv(iq).EQ.2 ) PRINT *,' Choix du shema  amont',' pour le'
+
+     * ,' traceur no ', iq
+       IF( iadv(iq).EQ.3 ) PRINT *,' Choix du shema  Van-Leer ',' pour'
+     * ,'le traceur no ', iq
+
+       IF( iadv(iq).EQ.4 )  THEN
+         PRINT *,' Le shema  Van-Leer + humidite specifique ',
+     * ' est  uniquement pour la vapeur d eau .'
+         PRINT *,' Corriger iadv( ',iq, ')  et repasser ! '
+         CALL ABORT
+       ENDIF
+
+       IF( iadv(iq).LE.0.OR.iadv(iq).GT.4 )   THEN
+        PRINT *,' Erreur dans le choix de iadv (nqmx).Corriger et '
+     * ,' repasser car  iadv(iq) = ', iadv(iq)
+         CALL ABORT
+       ENDIF
+      ENDDO
+
+       IF( iadv(nqmx).EQ.1 ) PRINT *,' Choix du shema humidite '
+     * ,'specifique pour la vapeur d''eau'
+       IF( iadv(nqmx).EQ.2 ) PRINT *,' Choix du shema  amont',' pour la'
+     * ,' vapeur d''eau '
+       IF( iadv(nqmx).EQ.3 ) PRINT *,' Choix du shema  Van-Leer '
+     * ,' pour la vapeur d''eau'
+       IF( iadv(nqmx).EQ.4 ) PRINT *,' Choix du shema  Van-Leer + '
+     * ,' humidite specifique pour la vapeur d''eau'
+c
+       IF( iadv(nqmx).LE.0.OR.iadv(nqmx).GT.4 )   THEN
+        PRINT *,' Erreur dans le choix de iadv (nqmx).Corriger et '
+     * ,' repasser car  iadv(nqmx) = ', iadv(nqmx)
+         CALL ABORT
+       ENDIF
+
+      first = .TRUE.
+      numvanle = nqmx + 1
+      DO  iq = 1, nqmx
+        IF((iadv(iq).EQ.3.OR.iadv(iq).EQ.4).AND.first ) THEN
+          numvanle = iq
+          first    = .FALSE. 
+        ENDIF
+      ENDDO
+c
+      DO  iq = 1, nqmx
+
+      IF( (iadv(iq).NE.3.AND.iadv(iq).NE.4).AND.iq.GT.numvanle )  THEN
+          PRINT *,' Il y a discontinuite dans le choix du shema de ',
+     *    'Van-leer pour les traceurs . Corriger et repasser . '
+           CALL ABORT
+      ENDIF
+
+      ENDDO
+c
+
+      CALL dynetat0("start.nc",nqmx,vcov,ucov,
+     .              teta,q,masse,ps,phis, time_0)
+
+      CALL defrun_new( 99, .TRUE. )
+
+
+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
+
+      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 dump2d(iip1,jjp1,ps,'PRESSION SURFACE')
+      CALL exner_hyb( ip1jmp1, ps, p,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
+c ********************************
+c      itaufin = 120   ! temporaire !!
+c ********************************
+      itaufinp1 = itaufin +1
+
+      day_end = day_ini + nday
+      PRINT 300, itau,itaufin,day_ini,day_end
+ 300  FORMAT('1'/,15x,'run du pas',i7,2x,'au pas',i7,2x,  
+     . 'c''est a dire du jour',i7,3x,'au jour',i7//)
+
+      CALL dynredem0("restart.nc",day_end,anne_ini,phis,nqmx)
+
+      ecripar = .TRUE.
+
+      dtav = iperiod*dtvr/daysec
+
+
+c   Quelques initialisations pour les traceurs
+      call initial0(ijp1llm*nqmx,dq)
+c     istdyn=day_step/4     ! stockage toutes les 6h=1jour/4
+c     istphy=istdyn/iphysiq
+
+      write(*,*) "gcm: callgroupeun set to:",callgroupeun
+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 apres continue   OK ! -----', itau
+      ENDIF 
+
+      if (callgroupeun) then
+        call groupeun(jjp1,llm,ucov,.true.)
+        call groupeun(jjm,llm,vcov,.true.)
+        call groupeun(jjp1,llm,teta,.true.)
+        call groupeun(jjp1,llm,masse,.true.)
+        call groupeun(jjp1,1,ps,.false.)
+      endif
+
+      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   -----
+
+!      write(*,*) 'GCM: itau=',itau
+
+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 (tracer) then
+       IF( forward. OR . leapf )  THEN
+
+        DO iq = 1, nqmx
+c
+         IF ( iadv(iq).EQ.1.OR.iadv(iq).EQ.2 )  THEN
+            CALL traceur( iq,iadv,q,teta,pk,w, pbaru, pbarv, dq )
+
+         ELSE IF( iq.EQ. nqmx )   THEN
+c
+            iapp_tracvl = 5
+c
+cccc     iapp_tracvl est la frequence en pas du groupement des flux
+cccc      de masse pour  Van-Leer dans la routine  tracvl  .
+c
+
+            CALL vanleer(numvanle,iapp_tracvl,nqmx,q,pbaru,pbarv,
+     *                      p, masse, dq,  iadv(1), teta, pk     )
+
+c
+c                   ...  Modif  F.Codron  ....
+c
+         ENDIF
+c
+        ENDDO
+C
+c        IF (offline) THEN
+C maf stokage du flux de masse pour traceurs OFF-LINE
+
+c           CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis,
+c    .   time_step, itau)
+
+c        ENDIF
+c
+      ENDIF
+	  END IF   ! tracer
+
+
+c-----------------------------------------------------------------------
+c   integrations dynamique et traceurs:
+c   ----------------------------------
+
+       CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , 
+     $         dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ,
+     $              finvmaold )
+
+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,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 = INT( 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, dufi,dvfi,dhfi,dqfi,dpfi,tracer)
+
+
+c      ajout des tendances physiques:
+c      ------------------------------
+          CALL addfi( nqmx, dtphys, leapf, forward   ,
+     $                  ucov, vcov, teta , q   ,ps , masse,
+     $                 dufi, dvfi, dhfi , dqfi ,dpfi  )
+c
+       ENDIF
+
+       CALL pression ( ip1jmp1, ap, bp, ps, p                  )
+
+       CALL exner_hyb( ip1jmp1, ps, p,beta, pks, pk, pkf )
+c   ----------------------------------------------------------
+
+c
+c
+c   dissipation horizontale et verticale  des petites echelles:
+c   ----------------------------------------------------------
+
+
+      IF(apdiss) THEN
+
+c        Sponge layer
+c        ~~~~~~~~~~~~
+         DO ij=1, ip1jmp1
+            pext(ij)=ps(ij)*aire(ij)
+         ENDDO
+         IF (callsponge) THEN
+            CALL sponge(ucov,vcov,teta,pext,dtdiss,mode_sponge)
+         ENDIF
+
+c        Dissipation horizontale
+c        ~~~~~~~~~~~~~~~~~~~~~~~
+         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
+
+        DO l  =  1, llm
+          DO ij =  1,iim
+           tppn(ij)  = aire(  ij    ) * teta(  ij    ,l)
+           tpps(ij)  = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+          ENDDO
+
+           tpn  = SSUM(iim,tppn,1)/apoln
+           tps  = SSUM(iim,tpps,1)/apols
+
+          DO ij = 1, iip1
+           teta(  ij    ,l) = tpn
+           teta(ij+ip1jm,l) = tps
+          ENDDO
+        ENDDO
+
+        DO ij =  1,iim
+          tppn(ij)  = aire(  ij    ) * ps (  ij    )
+          tpps(ij)  = aire(ij+ip1jm) * ps (ij+ip1jm)
+        ENDDO
+          tpn  = SSUM(iim,tppn,1)/apoln
+
+          tps  = SSUM(iim,tpps,1)/apols
+
+        DO ij = 1, iip1
+          ps(  ij    ) = tpn
+          ps(ij+ip1jm) = tps
+        ENDDO
+
+
+      END IF
+        
+c   ********************************************************************
+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   -------------------------------------
+
+c           IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN
+c              IF(itau.EQ.itaufin) THEN
+c                 iav=1
+c              ELSE
+c                 iav=0
+c              ENDIF
+c              CALL writedynav(histaveid, nqmx, itau,vcov ,
+c    ,                          ucov,teta,pk,phi,q,masse,ps,phis)
+c           ENDIF
+
+c-----------------------------------------------------------------------
+
+
+            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
+c              CALL writedynav(histaveid, nqmx, itau,vcov ,
+c    ,                          ucov,teta,pk,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
+
+      STOP
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/geopot.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/geopot.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/geopot.F	(revision 57)
@@ -0,0 +1,69 @@
+      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)
+      real zz(ngrid)
+
+
+c   Local:
+c   ------
+
+      INTEGER  l, ij, count
+      logical flag 
+
+
+c-----------------------------------------------------------------------
+c     calcul de phi au niveau 1 pres du sol  .....
+
+      flag=.false.
+      count=0
+c     call dump2d(iip1,jjp1,teta(:,1),'TETA COUCHE 1')
+c     zz(:)=pks(:)-pk(:,1)
+c     call dump2d(iip1,jjp1,zz(:),'DPK SURF-1')
+
+      DO   ij  = 1, ngrid
+          phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) )
+      ENDDO
+
+c     calcul de phi aux niveaux superieurs  .......
+
+      DO  l = 2,llm
+        DO  ij    = 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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_dyn_fi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_dyn_fi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_dyn_fi.F	(revision 57)
@@ -0,0 +1,37 @@
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_fi_dyn.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_fi_dyn.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_fi_dyn.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_int_dyn.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_int_dyn.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_int_dyn.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_u_scal.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_u_scal.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_u_scal.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_v_scal.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_v_scal.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gr_v_scal.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grad.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grad.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grad.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv2.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv2.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradiv2.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradsdef.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradsdef.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/gradsdef.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_atob.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_atob.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_atob.F	(revision 57)
@@ -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,real(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,real(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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro.F	(revision 57)
@@ -0,0 +1,487 @@
+
+      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
+
+c     write (*,*) "zpic: ",zpic
+
+      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)
+      zphi(imar+1,jj)=zphi(1,jj)
+      zpic(imar+1,jj)=zpic(1,jj)
+      zval(imar+1,jj)=zval(1,jj)
+      zstd(imar+1,jj)=zstd(1,jj)
+      zsig(imar+1,jj)=zsig(1,jj)
+      zgam(imar+1,jj)=zgam(1,jj)
+      zthe(imar+1,jj)=zthe(1,jj)
+      ENDDO
+
+
+      zmeanor=0.0
+      zmeasud=0.0
+      zstdnor=0.0
+      zstdsud=0.0
+      zsignor=0.0
+      zsigsud=0.0
+      zweinor=0.0
+      zweisud=0.0
+      zpicnor=0.0
+      zpicsud=0.0                                   
+      zvalnor=0.0
+      zvalsud=0.0 
+
+      DO ii=1,imar
+      zweinor=zweinor+              weight(ii,   1)
+      zweisud=zweisud+              weight(ii,jmar)
+      zmeanor=zmeanor+zmea(ii,   1)*weight(ii,   1)
+      zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar)
+      zstdnor=zstdnor+zstd(ii,   1)*weight(ii,   1)
+      zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar)
+      zsignor=zsignor+zsig(ii,   1)*weight(ii,   1)
+      zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar)
+      zpicnor=zpicnor+zpic(ii,   1)*weight(ii,   1)
+      zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar)
+      zvalnor=zvalnor+zval(ii,   1)*weight(ii,   1)
+      zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/zweisud
+      zphi(ii,   1)=zmeanor/zweinor
+      zphi(ii,jmar)=zmeasud/zweisud
+      zpic(ii,   1)=zpicnor/zweinor
+      zpic(ii,jmar)=zpicsud/zweisud
+      zval(ii,   1)=zvalnor/zweinor
+      zval(ii,jmar)=zvalsud/zweisud
+      zstd(ii,   1)=zstdnor/zweinor
+      zstd(ii,jmar)=zstdsud/zweisud
+      zsig(ii,   1)=zsignor/zweinor
+      zsig(ii,jmar)=zsigsud/zweisud
+      zgam(ii,   1)=1.
+      zgam(ii,jmar)=1.
+      zthe(ii,   1)=0.
+      zthe(ii,jmar)=0.
+      ENDDO
+
+      RETURN
+      END
+
+      SUBROUTINE MVA9(X,IMAR,JMAR)
+
+C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS
+
+      PARAMETER (ISMo=300,JSMo=200)
+      REAL X(IMAR,JMAR),XF(ISMo,JSMo)
+      real 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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro1.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro1.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/grid_noro1.F	(revision 57)
@@ -0,0 +1,423 @@
+      SUBROUTINE grid_noro1(imdep, jmdep, xdata, ydata, entree,
+     .                 imar, jmar, x, y, zmea,zstd,zsig,zgam,zthe)
+c=======================================================================
+c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead)
+c
+c      Calcul des parametres de l'orographie sous-maille necessaires
+c      au nouveau shema de representation des montagnes meso-echelles
+c      dans le modele.  Les points sont mis sur une grille rectangulaire
+c      pseudo-physique.  Typiquement, il y a iim+1 latitudes incluant
+c      le pole nord et le pole sud.  Il y a jjm+1 longitudes, y compris
+c      aux poles.  Aux poles les champs peuvent ont une valeurs repetee
+c      jjm+1 fois.....  La valeur du champs en jjm+1 (jmar) est celle
+c      en j=1.  
+c      Les parametres a,b,c,d representent les limites de la region
+c      de point de grille correspondant a un point decrit precedemment.
+c      Les moyennes sur ces regions des valeurs calculees a partir de
+c      l'USN, sont ponderees par un poids, fonction de la surface
+c      occuppe par ces donnees a l'interieure de la grille du modele.
+c      Dans la plupart des cas ce poid est le rapport entre la surface
+c      de la region de point de grille USN et la surface de la region
+c      de point de grille du modele.
+c       
+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        dans ce programme, on assume que les donnees sont les altitudes
+c        de l'USNavy: imdep=iusn=2160, jmdep=jusn=1080.
+c OUTPUT:
+c        imar, jmar: dimensions X et Y d'arrivee
+c        x, y: coordonnees X et Y d'arrivee
+c        les champs de sorties sont sur une grille physique:
+c             zmea:  orographie moyenne
+c             zstd:  deviation standard de l'orographie sous-maille
+c             zsig:  pente de l'orographie sous-maille 
+c             zgam:  anisotropy de l'orographie sous maille
+c             zthe:  orientation de l'axe oriente dans la direction
+c                    de plus grande pente de l'orographie sous maille
+C=======================================================================
+c     IMPLICIT INTEGER (I,J)
+c     IMPLICIT REAL(X,Z) 
+       implicit none
+       integer iusn,jusn,iext
+       parameter(iusn=360,jusn=180,iext=40)
+c!-*-      include 'param1'
+c!-*-      include 'comcstfi.h'
+#include "dimensions.h"
+#include "comconst.h"
+c!-*-
+c!-*-      parameter(iim=cols,jjm=rows)
+      REAL xusn(iusn+2*iext),yusn(jusn+2)	
+      REAL zusn(iusn+2*iext,jusn+2),zusnfi(iusn+2*iext,jusn+2)
+
+c   modif declarations pour implicit none
+      real zmeanor,zmeasud,zstdnor,zstdsud,zsignor
+      real zsigsud,zweinor,zweisud
+      real xk,xl,xm,xw,xp,xq
+      real zmaxmea,zmaxstd,zmaxsig,zmaxgam,zmaxthe,zminthe
+      real zbordnor,zbordsud,zbordest,zbordoue,xpi
+      real zdeltax,zdeltay,zlenx,zleny,weighx,weighy,xincr
+      integer i,j,ii,jj,ideltax,ihalph
+
+      INTEGER imdep, jmdep
+      REAL xdata(imdep),ydata(jmdep) 
+      REAL entree(imdep,jmdep)
+c
+      INTEGER imar, jmar
+  
+      REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1)
+      REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1)
+      REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2)
+      REAL zxtzyusn(iusn+2*iext,jusn+2)
+      REAL weight(iim+1,jjm+1)
+      REAL x(imar+1),y(jmar)
+      REAL zmea(imar+1,jmar),zstd(imar+1,jmar)
+      REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar)
+c
+      REAL a(2200),b(2200),c(1100),d(1100)
+c
+c  quelques constantes:
+c
+      print *,' parametres de l orographie a l echelle sous maille' 
+      print*,'rad =',rad
+      print*,'Long et lat entree'
+      print*,(x(i),i=1,imar+1)
+      print*,(y(j),j=1,jmar)
+       print*,'Long et lat donnees'
+      print*,(xdata(i),i=1,imdep)
+      print*,(ydata(j),j=1,jmdep)
+
+      xpi=acos(-1.)
+      zdeltay=2.*xpi/float(jusn)*rad
+c
+c  quelques tests de dimensions:
+c    
+      IF (imar.GT.2200 .OR. jmar.GT.1100) THEN
+         PRINT*, 'imar ou jmar trop grand', imar, jmar
+         CALL ABORT
+      ENDIF
+
+      IF(imdep.ne.iusn.or.jmdep.ne.jusn)then
+         print *,' imdep ou jmdep mal dimensionnes:',imdep,jmdep
+         call abort
+      ENDIF
+
+      IF(imar+1.gt.iim+1.or.jmar.gt.jjm+1)THEN
+        print *,' imar ou jmar mal dimensionnes:',imar,jmar
+        call abort
+      ENDIF
+c
+C  Extension de la base de donnee de l'USN pour faciliter
+C  les calculs ulterieurs:
+c
+      DO j=1,jusn
+        yusn(j+1)=ydata(j)
+      DO i=1,iusn
+        zusn(i+iext,j+1)=entree(i,j)
+        xusn(i+iext)=xdata(i)
+      ENDDO
+      DO i=1,iext
+        zusn(i,j+1)=entree(iusn-iext+i,j)
+        xusn(i)=xdata(iusn-iext+i)-2.*xpi
+        zusn(iusn+iext+i,j+1)=entree(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  Calcul d'une orographie filtree aux hautes latitudes
+c  pour permettre des calculs plus isotropiques sur la pente
+c  des montagnes
+c
+       DO i=1,IUSN+2*iext
+       DO J=1,JUSN+2
+          zusnfi(i,j)=0.0
+       ENDDO
+       ENDDO
+
+      DO j=1,jusn
+            ideltax=1./cos(yusn(j+1))
+            ideltax=min(iusn/2-1,ideltax)
+            IF(MOD(IDELTAX,2).EQ.0)THEN
+              IDELTAX=IDELTAX+1
+            ENDIF
+            IHALPH=(IDELTAX-1)/2 
+c           print *,' ideltax=',ideltax
+         IF(ideltax.eq.1)THEN
+            DO i=1,iusn
+               zusnfi(i+iext,j+1)=entree(i,j)
+            ENDDO   
+         ELSE
+            DO i=1,ihalph
+               DO ii=1,i+ihalph
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j)
+               ENDDO
+               DO ii=ihalph-i,0,-1
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(iusn-ii,j)
+               ENDDO  
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax)
+            ENDDO   
+            DO i=iusn-ihalph+1,iusn
+               DO ii = i-ihalph,iusn
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j)
+               ENDDO 
+               DO ii = 1,ihalph+i-iusn
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j)
+               ENDDO
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax)
+            ENDDO
+            DO i=ihalph+1,iusn-ihalph
+               DO ii=-ihalph,ihalph
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(i+ii,j)
+               ENDDO
+               zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax)
+            ENDDO
+         ENDIF
+            DO i=1,iext
+               zusnfi(i,j+1)=zusnfi(iusn-iext+i,j+1)
+               zusnfi(i+iusn+iext,j+1)=zusnfi(i,j+1)
+            ENDDO
+      ENDDO
+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
+c
+c      quelques initialisations:
+      print*,'OKM1'
+c
+      DO i = 1, imar
+      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
+         zstd(i,j)=0.0
+      ENDDO
+      ENDDO
+c
+c  calculs des correlations de pentes sur la grille de l'USN.
+c
+         DO j = 2,jusn+1 
+         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)=(zusnfi(i+1,j)-zusnfi(i-1,j))**2/zdeltax**2
+            zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay
+     *                   *(zusnfi(i+1,j)-zusnfi(i-1,j))/zdeltax
+         ENDDO
+
+         ENDDO
+
+ 
+
+      print*,'OK0'
+c
+c  sommations des differentes quantites definies precedemment
+c  sur une grille du modele.
+c 
+      zleny=xpi/float(jusn)*rad
+      xincr=xpi/2./float(jusn)
+       DO ii = 1, imar
+       DO jj = 1, jmar
+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
+            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
+            zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy
+            ENDIF
+         ENDDO
+         ENDIF
+         ENDDO
+       ENDDO
+       ENDDO
+c
+c  calculs des differents parametres necessaires au programme
+c  de parametrisation de l'orographie a l'echelle moyenne:
+c
+      zmaxmea=0.
+      zmaxstd=0.
+      zmaxsig=0.
+      zmaxgam=0.
+      zmaxthe=0.
+      zminthe=0.
+c     print 100,' '
+c100  format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') 
+       print*,'OK1'
+       DO ii = 1, imar
+       DO jj = 1, jmar
+c       print*,'ok0'
+         IF (weight(ii,jj) .NE. 0.0) THEN
+c  Orography moyenne:
+c         print*,'ok1'
+           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         print*,'ok2'
+c  Deviation standard:
+           zstd(ii,jj)=sqrt(amax1(0.,ztz(ii,jj)-zmea(ii,jj)**2))
+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          print*,'ok3'
+c pente: 
+           zsig(ii,jj)=sqrt(xq)
+c           zsig(ii,jj)=sqrt(2.*xk)
+c isotropy:
+           zgam(ii,jj)=xp/xq
+c angle theta:
+           zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.
+
+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)     
+c          print*,'ok4'
+         ELSE
+c           PRINT*, 'probleme,ii,jj=', ii,jj
+c          print*,'ok1b'
+         ENDIF
+      zmaxmea=amax1(zmea(ii,jj),zmaxmea)
+c         print*,'oka'
+      zmaxstd=amax1(zstd(ii,jj),zmaxstd)
+c         print*,'okb'
+      zmaxsig=amax1(zsig(ii,jj),zmaxsig)
+c         print*,'okc'
+      zmaxgam=amax1(zgam(ii,jj),zmaxgam)
+c         print*,'okd'
+      zmaxthe=amax1(zthe(ii,jj),zmaxthe)
+c         print*,'oke'
+      zminthe=amin1(zthe(ii,jj),zminthe)
+c      print*,'ok5'
+       ENDDO
+       ENDDO
+
+      print *,'  MEAN ORO:',zmaxmea
+	  print *,'  ST. DEV.:',zmaxstd
+      print *,'  PENTE:',zmaxsig
+      print *,' ANISOTROP:',zmaxgam
+      print *,'  ANGLE:',zminthe,zmaxthe	
+      
+C
+c  On passe ce donnees sur la grille dite physique....(?)
+c  On met gamma et theta a 1. et 0. aux poles ou ces quantites
+c  n'ont pas vraiment de sens
+c
+      DO jj=1,jmar
+      zmea(imar+1,jj)=zmea(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
+
+      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)
+      ENDDO
+
+      DO ii=1,imar+1
+      zmea(ii,   1)=zmeanor/zweinor
+      zmea(ii,jmar)=zmeasud/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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupe.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupe.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupe.F	(revision 57)
@@ -0,0 +1,83 @@
+      subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm)
+      implicit none
+
+c   SEE COMMENTS IN groupeun.F
+c
+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"
+
+
+      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
+
+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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupeun.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupeun.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/groupeun.F	(revision 57)
@@ -0,0 +1,145 @@
+!Mars importe directement de la version martienne 
+      subroutine groupeun(jjmax,llmax,q)
+      implicit none
+
+c *********************************************************
+c     lissage fort des champs aux poles pour permettre 
+c     de tourner avec plafond haut.
+c     F. Hourdin, 1997.
+c     (commentaire et test sur ngroup par Francois Forget, 05/2000)
+c
+c     Technique :
+c
+c     1) Les points sont regroupes par paquet de 2**ngroup 
+c     aux poles (e.g. ngroup=3 -> paquet de 8), puis 2**(ngroup-1)
+c     2**(ngroup-2), etc... aux latitude plus basse en s'eloignant du pole
+c
+c     2) Plus ngroup est eleve, plus le lissage est efficace
+c
+c     3) MAIS, il faut iim divisible par 2**ngroup !!!
+c
+c
+c *********************************************************
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+
+      integer jjmax,llmax
+      real q(iip1,jjmax,llmax)
+
+      integer ngroup
+      parameter (ngroup=2) 
+
+      logical intensive
+
+      real airen,airecn,qn
+      real aires,airecs,qs
+
+      integer i,j,l,ig,j1,j2,i0,jd
+      logical firstcall
+      DATA firstcall/.true./
+
+c -------------------------------------------------------
+c   test sur ngroup :
+
+      if (firstcall) then
+        IF(MOD(iim,2**ngroup).NE.0) then
+           write(*,*) 'Problem in groupeun.F'
+           write(*,*) 'iim= ', iim, ' ngroup=', ngroup
+           write(*,*) 'iim must be divisible by par 2**ngroup= ',
+     &                 2**ngroup
+           write(*,*) ' YOU must change ngroup in groupeun.F'
+           write(*,*) ' Have fun... '
+           stop
+        END IF
+        write(*,*) 'in groupeun.F, ngroup=', ngroup
+        firstcall = .false.
+      end if
+      
+
+c Champs 3D
+      intensive=.true.
+      if (intensive) then
+      jd=jjp1-jjmax
+      do l=1,llmax
+       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)*aire(i,j)
+                  qs=qs+q(i,jjp1-j+1-jd,l)*aire(i,jjp1-j+1)
+               enddo
+               airecn=0.
+               airecs=0.
+               do i=i0,i0+2**(ngroup-ig+1)-1
+                  q(i,j,l)=qn/airen
+                  q(i,jjp1-j+1-jd,l)=qs/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
+
+c  ---------------
+      else
+c   Cas sans multiplication par les aires.
+c  ---------------
+
+      jd=jjp1-jjmax
+      do l=1,llmax
+      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
+
+      endif
+
+c     print*,'On groupe jusque j=',j1-1,rlatu(j1-1)*180./pi
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/heavyside.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/heavyside.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/heavyside.F	(revision 57)
@@ -0,0 +1,21 @@
+c
+c $Header: /users/lmdz/cvsroot/LMDZ.3.3/libf/dyn3d/heavyside.F,v 1.2 2001/04/13 15:49:10 lmdz Exp $
+c
+       FUNCTION heavyside(a)
+
+c      ...   P. Le Van  ....
+c
+       IMPLICIT NONE
+
+       REAL*8 heavyside , a
+
+       IF ( a.LE.0. )  THEN
+         heavyside = 0.
+       ELSE
+         heavyside = 1.
+       ENDIF
+
+       RETURN
+       END
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ini_archive.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ini_archive.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ini_archive.F	(revision 57)
@@ -0,0 +1,473 @@
+c=======================================================================
+      subroutine ini_archive(nid,idayref,phis,tab_cntrl_fi)
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c   Objet:  ecriture de l'entete du fichier "start_archive"
+c   -----
+c
+c	 Proche de iniwrite.F
+c
+c	 On ajoute dans le tableau "tab_cntrl" (dynamique), a partir de 51, 
+c	 les valeurs de tab_cntrl_fi (les 38 parametres de controle physiques
+c	 du RUN + ptotal et cotoicetotal)
+c
+c			tab_cntrl(50+l)=tab_cntrl_fi(l)
+c
+c   Arguments:
+c   ---------
+c
+c	Inputs:
+c   ------
+c
+c       nid            unite logique du fichier "start_archive"
+c       idayref        Valeur du jour initial a mettre dans
+c                      l'entete du fichier "start_archive"
+c       phis           geopotentiel au sol
+c       tab_cntrl_fi   tableau des param physiques
+c
+
+c=======================================================================
+ 
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "description.h"
+#include "serre.h"
+#include "netcdf.inc"
+#include "control.h"
+
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c   Local:
+c   ------
+      INTEGER	length,l
+      parameter (length = 100)
+      REAL		tab_cntrl(length) ! tableau des parametres du run
+      INTEGER	loop
+      INTEGER	ierr, setvdim, putvdim, putdat, setname,cluvdb
+      INTEGER	setdim
+      INTEGER	ind1,indlast
+
+c   Arguments:
+c   ----------
+      INTEGER*4	idayref
+      REAL		phis(ip1jmp1)
+      REAL		tab_cntrl_fi(length)
+
+!Mars --------Ajouts-----------
+c   Variables locales pour NetCDF:
+c
+      INTEGER dims2(2), dims3(3), dims4(4)
+      INTEGER idim_index
+      INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv
+      INTEGER idim_llmp1,idim_llm
+      INTEGER idim_tim
+      INTEGER nid,nvarid
+      real sig_s(llm),s(llm)
+
+      pi  = 2. * ASIN(1.)
+
+
+c-----------------------------------------------------------------------
+c   Remplissage du tableau des parametres de controle du RUN  (dynamique)
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+      tab_cntrl(1)  = FLOAT(iim) ! nombre de points en longitude
+      tab_cntrl(2)  = FLOAT(jjm) ! nombre de points en latitude
+      tab_cntrl(3)  = FLOAT(llm) ! nombre de couches
+      tab_cntrl(4)  = FLOAT(idayref) ! jour 0
+      tab_cntrl(5)  = rad ! rayon de mars(m) ~3397200
+      tab_cntrl(6)  = omeg ! vitesse de rotation (rad.s-1)
+      tab_cntrl(7)  = g   ! gravite (m.s-2) ~3.72
+      tab_cntrl(8)  = cpp 
+      tab_cntrl(8)  = 43.49 !mars temporaire Masse molaire de l''atm (g.mol-1) ~43.49
+      tab_cntrl(9)  = kappa ! = r/cp  ~0.256793 (=rcp dans physique)
+      tab_cntrl(10) = daysec ! duree du sol (s)  ~88775
+      tab_cntrl(11) = dtvr ! pas de temps de la dynamique (s)
+      tab_cntrl(12) = etot0 ! energie totale    !
+      tab_cntrl(13) = ptot0 ! pression totalei   !    variables
+      tab_cntrl(14) = ztot0 ! enstrophie totale   !  de controle
+      tab_cntrl(15) = stot0 ! enthalpie totale   !    globales
+      tab_cntrl(16) = ang0 ! moment cinetique  !
+      tab_cntrl(17) = pa
+      tab_cntrl(18) = preff
+
+c    .....    parametres  pour le zoom      ......   
+
+      tab_cntrl(19)  = clon ! longitude en degres du centre du zoom
+      tab_cntrl(20)  = clat ! latitude en degres du centre du zoom
+      tab_cntrl(21)  = grossismx ! facteur de grossissement du zoom,selon longitude
+      tab_cntrl(22)  = grossismy ! facteur de grossissement du zoom ,selon latitude
+
+      IF ( fxyhypb )   THEN
+       tab_cntrl(23) = 1.
+       tab_cntrl(24) = dzoomx ! extension en longitude  de la zone du zoom
+       tab_cntrl(25) = dzoomy ! extension en latitude  de la zone du zoom
+      ELSE
+       tab_cntrl(23) = 0.
+       tab_cntrl(24) = dzoomx ! extension en longitude  de la zone du zoom
+       tab_cntrl(25) = dzoomy ! extension en latitude  de la zone du zoom
+       tab_cntrl(26) = 0.
+       IF ( ysinus)  tab_cntrl(26) = 1.
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   Copie du tableau des parametres de controle du RUN  (physique)
+c		dans le tableau dynamique
+c-----------------------------------------------------------------------
+
+      DO l=1,50
+         tab_cntrl(50+l)=tab_cntrl_fi(l)
+      ENDDO
+
+c=======================================================================
+c	Ecriture NetCDF de l''entete du fichier "start_archive"
+c=======================================================================
+
+c
+c Preciser quelques attributs globaux:
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27,
+     .                       "Fichier start_archive")
+c
+c Definir les dimensions du fichiers:
+c
+c     CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret:
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+
+
+      ierr = NF_DEF_DIM (nid,"index", length, idim_index)
+      ierr = NF_DEF_DIM (nid,"rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid,"rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid,"interlayer", llmp1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid,"Time", NF_UNLIMITED, idim_tim)
+
+c
+      ierr = NF_ENDDEF(nid) ! sortir du mode de definition
+
+c-----------------------------------------------------------------------
+c  Ecriture du tableau des parametres du run
+c-----------------------------------------------------------------------
+
+      call def_var(nid,"Time","Time","days since 00:00:00",1,
+     .            idim_tim,nvarid,ierr)
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Parametres de controle")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture des longitudes et latitudes
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                       "Longitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Latitudes des points V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture des niveaux verticaux
+c-----------------------------------------------------------------------
+
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32,
+     .                       "Coef A: niveaux pression hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 35,
+     .                       "Coefficient B niveaux sigma hybride")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 36,
+     .      "Coef AS: hybrid pressure in midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+c
+c ----------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 30,
+     .      "Coef BS: hybrid sigma midlayers")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+c
+c ----------------------
+
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid)
+#endif
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs)
+#endif
+c ------------------------------------------------------------------
+c  Variable uniquement pour visualisation avec Grads ou Ferret
+c ------------------------------------------------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c----------------------
+       ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c--------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1,
+     .       idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1,
+     .       idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture aire et coefficients de passage cov. <-> contra. <--> naturel
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonu
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour U")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatv
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29,
+     .                       "Coefficient de passage pour V")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+c Aire de chaque maille:
+c
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22,
+     .                       "Aires de chaque maille")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+
+c-----------------------------------------------------------------------
+c  Ecriture du geopentiel au sol
+c-----------------------------------------------------------------------
+
+      ierr = NF_REDEF (nid)
+      dims2(1) = idim_rlonv
+      dims2(2) = idim_rlatu
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                       "Geopotentiel au sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+
+      PRINT*,'iim,jjm,llm,idayref',iim,jjm,llm,idayref
+      PRINT*,'rad,omeg,g,mugaz,kappa',
+     s rad,omeg,g,43.49,kappa !mars temporaire (ecrire mugaz ensuite)
+      PRINT*,'daysec,dtvr',daysec,dtvr
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniav.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniav.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniav.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniconst.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniconst.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniconst.F	(revision 57)
@@ -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"
+
+
+      INTEGER :: l
+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  CPP  Kappa ',  r , cpp,  kappa
+c
+c-----------------------------------------------------------------------
+      CALL disvert
+c
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inidissip.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inidissip.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inidissip.F	(revision 57)
@@ -0,0 +1,287 @@
+      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 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
+      real sig_s(llm)
+      save sig_s
+      logical firstcall
+      data firstcall/.true./
+      save firstcall 
+
+      REAL fac_mid
+      REAL fac_up
+      REAL delta
+      REAL middle,startalt
+      SAVE fac_mid, fac_up, delta, startalt, middle
+
+c ------------------------------------------------------
+      if (firstcall) then
+         firstcall=.false.
+         do l=1,llm
+            sig_s(l)=aps(l)/preff + bps(l)
+         enddo
+
+c        COMPUTING THE VARIATION OF DISSIPATION AS A FUNCTION OF MODEL TOP :
+c         FF 2004       
+         if (pseudoalt(llm).lt.160.) then 
+             fac_mid=2  ! coeff  pour dissipation aux basses/moyennes altitudes
+             fac_up=10 ! coeff multiplicateur pour dissipation hautes altitudes
+             startalt=90. ! altitude en Km de la transition mid / up
+             delta=20.! Intervalle (km) pour le changement mid / up
+         else ! thermosphere model
+             fac_mid=2 ! coeff pour dissipation aux basses/moyennes altitudes
+             fac_up=25 ! coeff multiplicateur pour dissipation hautes altitudes
+c            startalt: 95 OK for MY24
+             startalt=95. ! altitude en Km de la transition mid / up
+             delta=30.! Intervalle (km) pour le changement mid /up
+         end if
+         middle=startalt+delta/2
+         write(*,*) 'Dissipation : '
+         write(*,*) 'Multiplication de la dissipation en altitude :',
+     &          ' fac_mid, fac_up =', fac_mid, fac_up 
+         write(*,*) 'Transition mid /up : startalt, delta =',
+     &             startalt, delta , '(km)'
+      endif
+
+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
+               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
+c        fac_mid    = rad*24./float(jjm)
+c        fac_mid    = fac_mid*fac_mid
+c        PRINT*,'coef u ', fac_mid/cdivu, 1./cdivu
+c        PRINT*,'coef r ', fac_mid/crot , 1./crot
+c        PRINT*,'coef h ', fac_mid/cdivh, 1./cdivh
+c     ENDIF
+
+c-----------------------------------------------------------------------
+c   variation verticale du coefficient de dissipation:
+c   --------------------------------------------------
+
+      DO l=1,llm
+         zvert(l)=1.
+      ENDDO
+
+c
+      DO l = 1, llm
+         zz   = 1. -1./sig_s(l)
+         zvert(l)= fac_mid -( fac_mid-1.)/( 1.+zz*zz )
+
+c ---------------------------------------------------------------
+c Utilisation de la fonction tangente hyperbolique pour augmenter
+c arbitrairement la dissipation et donc la stabilite du modele a 
+c partir d'une certaine altitude.
+
+c   Le facteur multiplicatif de basse atmosphere etant deja pris 
+c   en compte, il faut diviser le facteur multiplicatif de haute 
+c   atmosphere par celui-ci.
+c   ============================================================
+
+         zvert(l)= zvert(l)*(1.0+((fac_up/fac_mid-1)
+     &   *(1-(0.5*(1+tanh(-6./delta*    
+     &   (10.*(-log(sig_s(l)))-middle)))))
+     &   ))
+      ENDDO
+ 
+c -----------------------------------------------------------------------------
+
+c
+
+      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
+
+c     Calcul automatique de idissip
+c     -----------------------------
+c    :::::::::::::::::::::
+c     A Commenter pour garder la valeur de run.def :
+c     idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod
+c     idissip = MAX(iperiod,idissip)
+c    :::::::::::::::::::::
+      dtdiss  = idissip * dtvr
+ 
+      PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod
+      PRINT *,' INIDI tetamin idissip ',tetamin,idissip
+      PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss
+
+      PRINT*,'pseudoZ(km)  zvert  dt(tetagdiv) dt(tetagrot) dt(divgrad)'
+      DO l = 1,llm
+         PRINT*,pseudoalt(l),zvert(l),dtdiss*tetaudiv(l),
+     *        dtdiss*tetaurot(l),dtdiss*tetah(l)
+         if ( (dtdiss*tetaudiv(l).gt.1.9).or.
+     &        (dtdiss*tetaurot(l).gt.1.9).or.
+     &        (dtdiss*tetah(l).gt.1.9)) then
+          PRINT *,'STOP : your dissipation is too intense for the '      
+          PRINT *,'dissipation timestep : unstable model !'
+          PRINT *,'in run.def, you must increase tetagdiv,' 
+          PRINT *,'(or tetagrot and tetatemp if they are smaller than'
+          PRINT *,'tetagdiv) OR decrease idissip OR increase day_step)' 
+          stop
+         end if
+  
+      ENDDO
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigeom.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigeom.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigeom.F	(revision 57)
@@ -0,0 +1,699 @@
+c
+c $Header: /users/lmdz/cvsroot/LMDZ.3.3/libf/dyn3d/inigeom.F,v 1.3 2001/04/13 15:49:10 lmdz Exp $
+c
+      SUBROUTINE inigeom
+c
+c     Auteur :  P. Le Van
+c
+c   ............      Version  du 01/04/2001     ........................
+c
+c  Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4  aux memes en-
+c     endroits que les aires aireij1,..aireij4 .
+
+c  Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol.
+c
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comgeom2.h"
+#include "serre.h"
+#include "logic.h"
+#include "comdissnew.h"
+
+c-----------------------------------------------------------------------
+c   ....  Variables  locales   ....
+c
+      INTEGER  i,j,itmax,itmay,iter
+      REAL cvu(iip1,jjp1),cuv(iip1,jjm)
+      REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm
+      REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm
+      REAL coslatm,coslatp,radclatm,radclatp
+      REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1),
+     *     cuij4(iip1,jjp1)
+      REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1),
+     *     cvij4(iip1,jjp1)
+      REAL rlonvv(iip1),rlatuu(jjp1)
+      REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) ,
+     *     yprimv(jjm),yprimu(jjp1)
+      REAL gamdi_gdiv, gamdi_grot, gamdi_h
+ 
+      REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),
+     ,  xprimp025(iip1)
+      SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu
+      SAVE rlonm025,xprimm025,rlonp025,xprimp025
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+c
+c
+c   ------------------------------------------------------------------
+c   -                                                                -
+c   -    calcul des coeff. ( cu, cv , 1./cu**2,  1./cv**2  )         -
+c   -                                                                -
+c   ------------------------------------------------------------------
+c
+c      les coef. ( cu, cv ) permettent de passer des vitesses naturelles
+c      aux vitesses covariantes et contravariantes , ou vice-versa ...
+c
+c
+c     on a :  u (covariant) = cu * u (naturel)   , u(contrav)= u(nat)/cu
+c             v (covariant) = cv * v (naturel)   , v(contrav)= v(nat)/cv
+c
+c       on en tire :  u(covariant) = cu * cu * u(contravariant)
+c                     v(covariant) = cv * cv * v(contravariant)
+c
+c
+c     on a l'application (  x(X) , y(Y) )   avec - im/2 +1 <  X  < im/2
+c                                                          =     =
+c                                           et   - jm/2    <  Y  < jm/2
+c                                                          =     =
+c
+c      ...................................................
+c      ...................................................
+c      .  x  est la longitude du point  en radians       .
+c      .  y  est la  latitude du point  en radians       .
+c      .                                                 .
+c      .  on a :  cu(i,j) = rad * COS(y) * dx/dX         .
+c      .          cv( j ) = rad          * dy/dY         .
+c      .        aire(i,j) =  cu(i,j) * cv(j)             .
+c      .                                                 .
+c      . y, dx/dX, dy/dY calcules aux points concernes   .
+c      .                                                 .
+c      ...................................................
+c      ...................................................
+c
+c
+c
+c                                                           ,
+c    cv , bien que dependant de j uniquement,sera ici indice aussi en i
+c          pour un adressage plus facile en  ij  .
+c
+c
+c
+c  **************  aux points  u  et  v ,           *****************
+c      xprimu et xprimv sont respectivement les valeurs de  dx/dX
+c      yprimu et yprimv    .  .  .  .  .  .  .  .  .  .  .  dy/dY
+c      rlatu  et  rlatv    .  .  .  .  .  .  .  .  .  .  .la latitude
+c      cvu    et   cv      .  .  .  .  .  .  .  .  .  .  .    cv
+c
+c  **************  aux points u, v, scalaires, et z  ****************
+c      cu, cuv, cuscal, cuz sont respectiv. les valeurs de    cu
+c
+c
+c
+c         Exemple de distribution de variables sur la grille dans le
+c             domaine de travail ( X,Y ) .
+c     ................................................................
+c                  DX=DY= 1
+c
+c   
+c        +     represente  un  point scalaire ( p.exp  la pression )
+c        >     represente  la composante zonale du  vent
+c        V     represente  la composante meridienne du vent
+c        o     represente  la  vorticite
+c
+c       ----  , car aux poles , les comp.zonales covariantes sont nulles
+c
+c
+c
+c         i ->
+c
+c         1      2      3      4      5      6      7      8
+c  j
+c  v  1   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     2   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     3   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     4   +   >  +   >  +   >  +   >  +   >  +   >  +   >  +  >
+c
+c         V   o  V   o  V   o  V   o  V   o  V   o  V   o  V  o
+c
+c     5   + ---- + ---- + ---- + ---- + ---- + ---- + ---- + --
+c
+c
+c      Ci-dessus,  on voit que le nombre de pts.en longitude est egal
+c                 a   IM = 8
+c      De meme ,   le nombre d'intervalles entre les 2 poles est egal
+c                 a   JM = 4
+c
+c      Les points scalaires ( + ) correspondent donc a des valeurs
+c       entieres  de  i ( 1 a IM )   et  de  j ( 1 a  JM +1 )   .
+c
+c      Les vents    U       ( > ) correspondent a des valeurs  semi-
+c       entieres  de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1)
+c
+c      Les vents    V       ( V ) correspondent a des valeurs entieres
+c       de     i ( 1 a  IM ) et semi-entieres de  j ( 1 +0.5  a JM +0.5)
+c
+c
+c
+      WRITE(6,3) 
+ 3    FORMAT( // 10x,' ....  INIGEOM  date du 01/06/98   ..... ',
+     * //5x,'   Calcul des elongations cu et cv  comme sommes des 4 ' /
+     *  5x,' elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux 
+     * '/ 5x,' memes endroits que les aires aireij1,...j4   . ' / )
+c
+c
+      IF( nitergdiv.NE.2 ) THEN
+        gamdi_gdiv = coefdis/ ( float(nitergdiv) -2. )
+      ELSE
+        gamdi_gdiv = 0.
+      ENDIF
+      IF( nitergrot.NE.2 ) THEN
+        gamdi_grot = coefdis/ ( float(nitergrot) -2. )
+      ELSE
+        gamdi_grot = 0.
+      ENDIF
+      IF( niterh.NE.2 ) THEN
+        gamdi_h = coefdis/ ( float(niterh) -2. )
+      ELSE
+        gamdi_h = 0.
+      ENDIF
+
+      WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis,
+     *  nitergdiv,nitergrot,niterh
+c
+      pi    = 2.* ASIN(1.)
+c
+      WRITE(6,990) 
+
+c     ----------------------------------------------------------------
+c
+      IF( .NOT.fxyhypb )   THEN
+c
+c
+       IF( ysinus )  THEN
+c
+        WRITE(6,*) ' ***  Inigeom ,  Y = Sinus ( Latitude ) *** '
+c
+c   .... utilisation de f(x,y )  avec  y  =  sinus de la latitude  .....
+
+        CALL  fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,                    rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ELSE
+c
+        WRITE(6,*) '*** Inigeom ,  Y = Latitude  , der. sinusoid . ***'
+
+c  .... utilisation  de f(x,y) a tangente sinusoidale , y etant la latit. ...
+c
+ 
+        pxo   = clon *pi /180.
+        pyo   = 2.* clat* pi /180.
+c
+c  ....  determination de  transx ( pour le zoom ) par Newton-Raphson ...
+c
+        itmax = 10
+        eps   = .1e-7
+c
+        xo1 = 0.
+        DO 10 iter = 1, itmax
+        x1  = xo1
+        f   = x1+ alphax *SIN(x1-pxo)
+        df  = 1.+ alphax *COS(x1-pxo)
+        x1  = x1 - f/df
+        xdm = ABS( x1- xo1 )
+        IF( xdm.LE.eps )GO TO 11
+        xo1 = x1
+ 10     CONTINUE
+ 11     CONTINUE
+c
+        transx = xo1
+
+        itmay = 10
+        eps   = .1e-7
+C
+        yo1  = 0.
+        DO 15 iter = 1,itmay
+        y1   = yo1
+        f    = y1 + alphay* SIN(y1-pyo)
+        df   = 1. + alphay* COS(y1-pyo)
+        y1   = y1 -f/df
+        ydm  = ABS(y1-yo1)
+        IF(ydm.LE.eps) GO TO 17
+        yo1  = y1
+ 15     CONTINUE
+c
+ 17     CONTINUE
+        transy = yo1
+
+        CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1,
+     ,              rlatu2,yprimu2,
+     ,  rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025)
+
+       ENDIF
+c
+      ELSE
+c
+c   ....  Utilisation  de fxyhyper , f(x,y) a derivee tangente hyperbol.
+c   .....................................................................
+
+      WRITE(6,*)'*** Inigeom , Y = Latitude  , der.tg. hyperbolique ***'
+ 
+       CALL fxyhyper( clat, grossismy, dzoomy, tauy    , 
+     ,                clon, grossismx, dzoomx, taux    ,
+     , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2  ,
+     , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 )
+
+  
+      ENDIF
+c
+c  -------------------------------------------------------------------
+
+c
+      rlatu(1)    =     ASIN(1.)
+      rlatu(jjp1) =  - rlatu(1)
+c
+c
+c   ....  calcul  aux  poles  ....
+c
+      yprimu(1)      = 0.
+      yprimu(jjp1)   = 0.
+c
+c
+      un4rad2 = 0.25 * rad * rad
+c
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c   -                                                                  -
+c   -  calcul  des aires ( aire,aireu,airev, 1./aire, 1./airez  )      -
+c   -      et de   fext ,  force de coriolis  extensive  .             -
+c   -                                                                  -
+c   --------------------------------------------------------------------
+c   --------------------------------------------------------------------
+c
+c
+c
+c   A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont
+c   affectees 4 aires entourant P , calculees respectivement aux points
+c            ( i + 1/4, j - 1/4 )    :    aireij1 (i,j)
+c            ( i + 1/4, j + 1/4 )    :    aireij2 (i,j)
+c            ( i - 1/4, j + 1/4 )    :    aireij3 (i,j)
+c            ( i - 1/4, j - 1/4 )    :    aireij4 (i,j)
+c
+c           ,
+c   Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y).
+c   Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme
+c   des 4 aires  aireij1,aireij2,aireij3,aireij4 qui sont affectees au
+c   point (i,j) .
+c   On definit en outre les coefficients  alpha comme etant egaux a
+c    (aireij / aire), c.a.d par exp.  alpha1(i,j)=aireij1(i,j)/aire(i,j)
+c
+c   De meme, toute aire centree en 1 point U est egale a la somme des
+c   4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U .
+c    Idem pour  airev, airez .
+c
+c       On a ,pour chaque maille :    dX = dY = 1
+c
+c
+c                             . V
+c
+c                 aireij4 .        . aireij1
+c
+c                   U .       . P      . U
+c
+c                 aireij3 .        . aireij2
+c
+c                             . V
+c
+c
+c
+c
+c
+c   ....................................................................
+c
+c    Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4
+c   qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen
+c   taires cuij et les 4 elongat. cvij qui sont calculees aux memes 
+c     endroits  que les aireij   .    
+c
+c   ....................................................................
+c
+c     .......  do 35  :   boucle sur les  jjm + 1  latitudes   .....
+c
+c
+      DO 35 j = 1, jjp1
+c
+      IF ( j. eq. 1 )  THEN
+c
+      yprm           = yprimu1(j)
+      rlatm          = rlatu1(j)
+c
+      coslatm        = COS( rlatm )
+      radclatm       = 0.5* rad * coslatm
+c
+      DO 30 i = 1, iim
+      xprp           = xprimp025( i )
+      xprm           = xprimm025( i )
+
+      aireij2( i,1 ) = un4rad2 * coslatm  * xprp * yprm
+      aireij3( i,1 ) = un4rad2 * coslatm  * xprm * yprm
+      cuij2  ( i,1 ) = radclatm * xprp
+      cuij3  ( i,1 ) = radclatm * xprm
+      cvij2  ( i,1 ) = 0.5* rad * yprm
+      cvij3  ( i,1 ) = cvij2(i,1)
+  30  CONTINUE
+c
+      DO  i = 1, iim
+      aireij1( i,1 ) = 0.
+      aireij4( i,1 ) = 0.
+      cuij1  ( i,1 ) = 0.
+      cuij4  ( i,1 ) = 0.
+      cvij1  ( i,1 ) = 0.
+      cvij4  ( i,1 ) = 0.
+      ENDDO
+c
+      END IF
+c
+      IF ( j. eq. jjp1 )  THEN
+       yprp               = yprimu2(j-1)
+       rlatp              = rlatu2 (j-1)
+ccc       yprp             = fyprim( FLOAT(j) - 0.25 )
+ccc       rlatp            = fy    ( FLOAT(j) - 0.25 )
+c
+      coslatp             = COS( rlatp )
+      radclatp            = 0.5* rad * coslatp
+c
+      DO 31 i = 1,iim
+        xprp              = xprimp025( i )
+        xprm              = xprimm025( i )
+        aireij1( i,jjp1 ) = un4rad2 * coslatp  * xprp * yprp
+        aireij4( i,jjp1 ) = un4rad2 * coslatp  * xprm * yprp
+        cuij1(i,jjp1)     = radclatp * xprp
+        cuij4(i,jjp1)     = radclatp * xprm
+        cvij1(i,jjp1)     = 0.5 * rad* yprp
+        cvij4(i,jjp1)     = cvij1(i,jjp1)
+ 31   CONTINUE
+c
+       DO   i    = 1, iim
+        aireij2( i,jjp1 ) = 0.
+        aireij3( i,jjp1 ) = 0.
+        cvij2  ( i,jjp1 ) = 0.
+        cvij3  ( i,jjp1 ) = 0.
+        cuij2  ( i,jjp1 ) = 0.
+        cuij3  ( i,jjp1 ) = 0.
+       ENDDO
+c
+      END IF
+c
+
+      IF ( j .gt. 1 .AND. j .lt. jjp1 )  THEN
+c
+        rlatp    = rlatu2 ( j-1 )
+        yprp     = yprimu2( j-1 )
+        rlatm    = rlatu1 (  j  )
+        yprm     = yprimu1(  j  )
+cc         rlatp    = fy    ( FLOAT(j) - 0.25 )
+cc         yprp     = fyprim( FLOAT(j) - 0.25 )
+cc         rlatm    = fy    ( FLOAT(j) + 0.25 )
+cc         yprm     = fyprim( FLOAT(j) + 0.25 )
+
+         coslatm  = COS( rlatm )
+         coslatp  = COS( rlatp )
+         radclatp = 0.5* rad * coslatp
+         radclatm = 0.5* rad * coslatm
+c
+         DO 32 i = 1,iim
+         xprp            = xprimp025( i )
+         xprm            = xprimm025( i )
+      
+         ai14            = un4rad2 * coslatp * yprp
+         ai23            = un4rad2 * coslatm * yprm
+         aireij1 ( i,j ) = ai14 * xprp
+         aireij2 ( i,j ) = ai23 * xprp
+         aireij3 ( i,j ) = ai23 * xprm
+         aireij4 ( i,j ) = ai14 * xprm
+         cuij1   ( i,j ) = radclatp * xprp
+         cuij2   ( i,j ) = radclatm * xprp
+         cuij3   ( i,j ) = radclatm * xprm
+         cuij4   ( i,j ) = radclatp * xprm
+         cvij1   ( i,j ) = 0.5* rad * yprp
+         cvij2   ( i,j ) = 0.5* rad * yprm
+         cvij3   ( i,j ) = cvij2(i,j)
+         cvij4   ( i,j ) = cvij1(i,j)
+  32     CONTINUE
+c
+      END IF
+c
+c    ........       periodicite   ............
+c
+         cvij1   (iip1,j) = cvij1   (1,j)
+         cvij2   (iip1,j) = cvij2   (1,j)
+         cvij3   (iip1,j) = cvij3   (1,j)
+         cvij4   (iip1,j) = cvij4   (1,j)
+         cuij1   (iip1,j) = cuij1   (1,j)
+         cuij2   (iip1,j) = cuij2   (1,j)
+         cuij3   (iip1,j) = cuij3   (1,j)
+         cuij4   (iip1,j) = cuij4   (1,j)
+         aireij1 (iip1,j) = aireij1 (1,j )
+         aireij2 (iip1,j) = aireij2 (1,j )
+         aireij3 (iip1,j) = aireij3 (1,j )
+         aireij4 (iip1,j) = aireij4 (1,j )
+        
+  35  CONTINUE
+c
+c    ..............................................................
+c
+      DO 37 j = 1, jjp1
+      DO 36 i = 1, iim
+      aire    ( i,j )  = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) +
+     *                          aireij4(i,j)
+      alpha1  ( i,j )  = aireij1(i,j) / aire(i,j)
+      alpha2  ( i,j )  = aireij2(i,j) / aire(i,j)
+      alpha3  ( i,j )  = aireij3(i,j) / aire(i,j)
+      alpha4  ( i,j )  = aireij4(i,j) / aire(i,j)
+      alpha1p2( i,j )  = alpha1 (i,j) + alpha2 (i,j)
+      alpha1p4( i,j )  = alpha1 (i,j) + alpha4 (i,j)
+      alpha2p3( i,j )  = alpha2 (i,j) + alpha3 (i,j)
+      alpha3p4( i,j )  = alpha3 (i,j) + alpha4 (i,j)
+  36  CONTINUE
+c
+c
+      aire    (iip1,j) = aire    (1,j)
+      alpha1  (iip1,j) = alpha1  (1,j)
+      alpha2  (iip1,j) = alpha2  (1,j)
+      alpha3  (iip1,j) = alpha3  (1,j)
+      alpha4  (iip1,j) = alpha4  (1,j)
+      alpha1p2(iip1,j) = alpha1p2(1,j)
+      alpha1p4(iip1,j) = alpha1p4(1,j)
+      alpha2p3(iip1,j) = alpha2p3(1,j)
+      alpha3p4(iip1,j) = alpha3p4(1,j)
+  37  CONTINUE
+c
+
+      DO 42 j = 1,jjp1
+      DO 41 i = 1,iim
+      aireu       (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) +
+     *                                aireij3(i+1,j)
+      unsaire    ( i,j)= 1./ aire(i,j)
+      unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv )
+      unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h    )
+      airesurg   ( i,j)= aire(i,j)/ g
+  41  CONTINUE
+      aireu     (iip1,j)  = aireu  (1,j)
+      unsaire   (iip1,j)  = unsaire(1,j)
+      unsair_gam1(iip1,j) = unsair_gam1(1,j)
+      unsair_gam2(iip1,j) = unsair_gam2(1,j)
+      airesurg   (iip1,j) = airesurg(1,j)
+  42  CONTINUE
+c
+c
+      DO 48 j = 1,jjm
+c
+        DO i=1,iim
+         airev     (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) +
+     *                           aireij4(i,j+1)
+        ENDDO
+         DO i=1,iim
+          airez         = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) +
+     *                           aireij4(i+1,j+1)
+          unsairez(i,j) = 1./ airez
+          unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot )
+          fext    (i,j)   = airez * SIN(rlatv(j))* 2.* omeg
+         ENDDO
+        airev     (iip1,j)  = airev(1,j)
+        unsairez  (iip1,j)  = unsairez(1,j)
+        fext      (iip1,j)  = fext(1,j)
+        unsairz_gam(iip1,j) = unsairz_gam(1,j)
+c
+  48  CONTINUE
+c
+c
+c    .....      Calcul  des elongations cu,cv, cvu     .........
+c
+      DO    j   = 1, jjm
+       DO   i  = 1, iim
+       cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1))
+       cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j)  +cvij3(i,j) )
+       cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1))
+       unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) )
+       ENDDO
+       DO   i  = 1, iim
+       cuvsurcv (i,j)    = airev(i,j)  * unscv2(i,j)
+       cvsurcuv (i,j)    = 1./cuvsurcv(i,j)
+       cuvscvgam1(i,j)   = cuvsurcv (i,j) ** ( - gamdi_gdiv )
+       cuvscvgam2(i,j)   = cuvsurcv (i,j) ** ( - gamdi_h )
+       cvscuvgam(i,j)    = cvsurcuv (i,j) ** ( - gamdi_grot )
+       ENDDO
+       cv       (iip1,j)  = cv       (1,j)
+       cvu      (iip1,j)  = cvu      (1,j)
+       unscv2   (iip1,j)  = unscv2   (1,j)
+       cuv      (iip1,j)  = cuv      (1,j)
+       cuvsurcv (iip1,j)  = cuvsurcv (1,j)
+       cvsurcuv (iip1,j)  = cvsurcuv (1,j)
+       cuvscvgam1(iip1,j) = cuvscvgam1(1,j)
+       cuvscvgam2(iip1,j) = cuvscvgam2(1,j)
+       cvscuvgam(iip1,j)  = cvscuvgam(1,j)
+      ENDDO
+
+      DO  j     = 2, jjm
+        DO   i  = 1, iim
+        cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j))
+        unscu2    (i,j)  = 1./ ( cu(i,j) * cu(i,j) )
+        cvusurcu  (i,j)  =  aireu(i,j) * unscu2(i,j)
+        cusurcvu  (i,j)  = 1./ cvusurcu(i,j)
+        cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) 
+        cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h    ) 
+        cuscvugam (i,j)  = cusurcvu(i,j) ** ( - gamdi_grot )
+        ENDDO
+        cu       (iip1,j)  = cu(1,j)
+        unscu2   (iip1,j)  = unscu2(1,j)
+        cvusurcu (iip1,j)  = cvusurcu(1,j)
+        cusurcvu (iip1,j)  = cusurcvu(1,j)
+        cvuscugam1(iip1,j) = cvuscugam1(1,j)
+        cvuscugam2(iip1,j) = cvuscugam2(1,j)
+        cuscvugam (iip1,j) = cuscvugam(1,j)
+      ENDDO
+
+c
+c   ....  calcul aux  poles  ....
+c
+      DO    i      =  1, iip1
+        cu    ( i, 1 )  =   0.
+        unscu2( i, 1 )  =   0.
+        cvu   ( i, 1 )  =   0.
+c
+        cu    (i, jjp1) =   0.
+        unscu2(i, jjp1) =   0.
+        cvu   (i, jjp1) =   0.
+      ENDDO
+c
+c    ..............................................................
+c
+      DO j = 1, jjm
+        DO i= 1, iim
+         airvscu2  (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) )
+         aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot )
+        ENDDO
+         airvscu2  (iip1,j)  = airvscu2(1,j)
+         aivscu2gam(iip1,j)  = aivscu2gam(1,j)
+      ENDDO
+
+      DO j=2,jjm
+        DO i=1,iim
+         airuscv2   (i,j)    = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) )
+         aiuscv2gam (i,j)    = airuscv2(i,j)** ( - gamdi_grot ) 
+        ENDDO
+         airuscv2  (iip1,j)  = airuscv2  (1,j)
+         aiuscv2gam(iip1,j)  = aiuscv2gam(1,j)
+      ENDDO
+
+c
+c   calcul des aires aux  poles :
+c   -----------------------------
+c
+      apoln       = SSUM(iim,aire(1,1),1)
+      apols       = SSUM(iim,aire(1,jjp1),1)
+      unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) )
+      unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) )
+      unsapolnga2 = 1./ ( apoln ** ( - gamdi_h    ) )
+      unsapolsga2 = 1./ ( apols ** ( - gamdi_h    ) )
+c
+c-----------------------------------------------------------------------
+c     gtitre='Coriolis version ancienne'
+c     gfichier='fext1'
+c     CALL writestd(fext,iip1*jjm)
+c
+c   changement F. Hourdin calcul conservatif pour fext
+c   constang contient le produit a * cos ( latitude ) * omega
+c
+      DO i=1,iim
+         constang(i,1) = 0.
+      ENDDO
+      DO j=1,jjm-1
+        DO i=1,iim
+         constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1))
+        ENDDO
+      ENDDO
+      DO i=1,iim
+         constang(i,jjp1) = 0.
+      ENDDO
+c
+c   periodicite en longitude
+c
+      DO j=1,jjm
+        fext(iip1,j)     = fext(1,j)
+      ENDDO
+      DO j=1,jjp1
+        constang(iip1,j) = constang(1,j)
+      ENDDO
+
+c fin du changement
+
+c
+c-----------------------------------------------------------------------
+c
+       WRITE(6,*) '   ***  Coordonnees de la grille  *** '
+       WRITE(6,995)
+c
+       WRITE(6,*) '   LONGITUDES  aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,iip1
+         rlonvv(i) = rlonv(i)*180./pi
+        ENDDO
+       WRITE(6,400) rlonvv
+c
+       WRITE(6,995)
+       WRITE(6,*) '   LATITUDES   aux pts.   V  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjm
+         rlatuu(i)=rlatv(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjm)
+c
+        DO i=1,iip1
+          rlonvv(i)=rlonu(i)*180./pi
+        ENDDO
+       WRITE(6,995)
+       WRITE(6,*) '   LONGITUDES  aux pts.   U  ( degres )  '
+       WRITE(6,995)
+       WRITE(6,400) rlonvv
+       WRITE(6,995)
+
+       WRITE(6,*) '   LATITUDES   aux pts.   U  ( degres )  '
+       WRITE(6,995)
+        DO i=1,jjp1
+         rlatuu(i)=rlatu(i)*180./pi
+        ENDDO
+       WRITE(6,400) (rlatuu(i),i=1,jjp1)
+       WRITE(6,995)
+c
+444    format(f10.3,f6.0)
+400    FORMAT(1x,8f8.2)
+990    FORMAT(//)
+995    FORMAT(/)
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigrads.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigrads.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/inigrads.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniinterp_h.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniinterp_h.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/iniinterp_h.F	(revision 57)
@@ -0,0 +1,238 @@
+      subroutine iniinterp_h (imo,jmo,imn,jmn ,kmax,
+     &       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 kmax ! 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(kmax), jjk(kmax),jk(kmax),ik(kmax)
+       real intersec(kmax)  ! surface des intersections (m2)
+       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
+
+
+       
+ 
+c Autres variables
+c """"""""""""""""
+       integer i,j,ii,jj
+       integer imomx,jmomx,imnmx1,jmnmx1
+       parameter (imomx=361,jmomx=180,imnmx1=190,jmnmx1=100)
+       real a(imomx+1),b(imomx+1),c(jmomx+1),d(jmomx+1)
+       real an(imnmx1+1),bn(imnmx1+1)
+       real cn(jmnmx1+1),dn(jmnmx1+1)
+       real aa, bb,cc,dd
+       real pi
+
+       pi      = 2.*ASIN( 1. )
+
+c Test dimensions imnmx1 jmnmx1
+c""""""""""""""""""""""""""""""
+c test dimensionnement tableau airetest
+      if (imn.GT.imnmx1.OR.jmn.GT.jmnmx1) then
+        write(*,*) 'STOP pb dimensionnement'
+        write(*,*) 'il faut imn < imnmx1 et jmn < jmnmx1'
+        write(*,*) 'imn imnmx1', imn,imnmx1
+        write(*,*) 'jmn jmnmx1', jmn,jmnmx1
+        call exit(1)
+      endif
+
+      if (imo.GT.imomx.OR.jmo.GT.jmomx) then
+        write(*,*) 'STOP pb dimensionnement'
+        write(*,*) 'il faut imo < imomx et jmo < jmomx'
+        write(*,*) 'imo imomx', imo,imomx
+        write(*,*) 'jmo jmomx', jmo,jmomx
+        call exit(1)
+      endif
+
+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 ======================================
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c test dimenssion kmax (calcul de ktotal)
+c"""""""""""""""""""""""""""""""""""""""
+c Calcul de ktotal, mais ralonge beaucoup en temps => pour debug
+      write(*,*) 
+      write(*,*) 'DEBUT DU TEST KMAX'
+      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
+                     end if
+                enddo
+              enddo
+           end if
+        enddo
+      enddo
+
+      if (kmax.LT.ktotal) then
+         write(*,*)
+         write(*,*) '******** ATTENTION ********' 
+         write(*,*) 'kmax =',kmax 
+         write(*,*) 'ktotal =',ktotal 
+         write(*,*) 'Changer la valeur de kmax dans interp_horiz.F ' 
+         write(*,*) 'avec kmax >= ktotal' 
+         write(*,*) 'EXIT dans iniinterp_h'
+         call exit(1)
+      else
+         write(*,*) 'kmax =',kmax 
+         write(*,*) 'ktotal =',ktotal
+      end if
+      write(*,*) 'FIN DU TEST KMAX'
+      write(*,*) 
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/initial0.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/initial0.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/initial0.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/integrd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/integrd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/integrd.F	(revision 57)
@@ -0,0 +1,185 @@
+      SUBROUTINE integrd
+     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
+     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold )
+
+      IMPLICIT NONE
+
+
+c=======================================================================
+cccccccccccccccccccccccccccccccccccccccccccc
+c
+!Mars       VERSION MARTIENNE de integrd.F
+c
+c   ..   modification de l'integration de  q   . 26/04/94 ..
+c   ....   Si shema Van-leer pour advection de q , on n'integre pas  q
+c      car q  a ete deja integre   dans "tracvl.F" appele par vanleer   ...
+cccccccccccccccccccccccccccccccccccccccccccc
+
+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 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
+      DO  ij   = 1, iim
+        tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
+        tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
+      ENDDO
+        tpn      = SSUM(iim,tppn,1)/apoln
+        tps      = SSUM(iim,tpps,1)/apols
+
+      DO ij   = 1, iip1
+        teta(   ij   ,l)  = tpn
+        teta(ij+ip1jm,l)  = tps
+      ENDDO
+c
+
+      IF(leapf)  THEN
+         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
+         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
+         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
+      END IF
+
+  10  CONTINUE
+
+
+c
+c   .......  integration de   q   ......
+c
+c
+c     .....   FIN  de l'integration  de   q    .......
+
+c    .................................................................
+
+
+      IF( leapf )  THEN
+         CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
+         CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
+      END IF
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_horiz.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_horiz.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_horiz.F	(revision 57)
@@ -0,0 +1,199 @@
+      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 """"""""""""""""
+       INTEGER imnmx2,jmnmx2
+       parameter (imnmx2=190,jmnmx2=100)
+       REAL airetest(imnmx2+1,jmnmx2+1)
+       INTEGER ii,jj,l
+
+       REAL airen ((imnmx2+1)*(jmnmx2+1)) ! aire dans la nouvelle grille
+       REAL airentotn	! aire totale pole nord dans la nouvelle grille
+       REAL airentots	! aire totale pole sud dans la nouvelle grille
+c    Info sur les ktotal intersection entre les cases new/old grille
+
+c kmax: le nombre  max  d'intersections entre les 2 grilles horizontales
+c On fixe kmax a la taille de la grille des donnees martiennes (360x179) 
+c + des pouiemes (cas ou une maille est a cheval sur 2 ou 4 mailles)
+c  Il y a un test dans iniinterp_h pour s'assurer que ktotal < kmax
+       INTEGER kmax, k, ktotal
+       parameter (kmax = 360*179 + 200000)
+c      parameter (kmax = 360*179 + 40000)
+
+       INTEGER iik(kmax), jjk(kmax),jk(kmax),ik(kmax)
+       REAL intersec(kmax)
+       REAL R
+       REAL totn, tots
+       REAL prev_sumdim
+       save prev_sumdim
+       
+
+       logical firsttest, aire_ok
+       save firsttest
+       data firsttest /.true./
+       data aire_ok /.true./
+
+       integer imoS,jmoS,imnS,jmnS
+       save imoS,jmoS,imnS,jmnS
+       save ktotal,iik,jjk,jk,ik,intersec,airen
+       REAL pi
+
+c Test dimensions imnmx2 jmnmx2
+c""""""""""""""""""""""""""""""
+c test dimensionnement tableau airetest
+      if (imn.GT.imnmx2.OR.jmn.GT.jmnmx2) then
+         write(*,*) 'STOP pb dimensionnement tableau airetest'
+         write(*,*) 'il faut imn < imnmx2 et jmn < jmnmx2'
+         write(*,*) 'imn imnmx2', imn,imnmx2
+         write(*,*) 'jmn jmnmx2', jmn,jmnmx2
+         call exit(1)
+      endif
+
+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.
+
+c  This must also be done if we change the dimension
+      if (imo+jmo+imn+jmn.ne.prev_sumdim) then
+          firsttest=.true.
+          prev_sumdim=imo+jmo+imn+jmn
+      end if       
+
+      if (firsttest) then 
+        call iniinterp_h(imo,jmo,imn,jmn ,kmax,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &          ktotal,iik,jjk,jk,ik,intersec,airen)
+       imoS=imo
+       jmoS=jmo
+       imnS=imn
+       jmnS=jmn
+      else
+       if(imo.NE.imoS.OR.jmo.NE.jmoS.OR.imn.NE.imnS.OR.jmn.NE.jmnS) then
+        call iniinterp_h(imo,jmo,imn,jmn ,kmax,
+     &       rlonuo,rlatvo,rlonun,rlatvn,
+     &          ktotal,iik,jjk,jk,ik,intersec,airen)
+       imoS=imo
+       jmoS=jmo
+       imnS=imn
+       jmnS=jmn
+       end if
+      end if
+
+      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)-1)*(imn+1))
+        end do
+      end do
+
+c Une seule valeur au pole pour les variables ! :
+c -----------------------------------------------
+      DO l=1, lm
+         totn =0.
+         tots =0.
+
+
+c moyenne du champ au poles (ponderee par les aires)
+c"""""""""""""""""""""""""""""""
+         airentotn=0.
+         airentots=0.
+
+         do ii =1, imn+1
+            totn = totn + varn(ii,1,l)*airen(ii)
+            tots = tots + varn (ii,jmn+1,l)*airen(jmn*(imn+1)+ii)
+            airentotn=airentotn + airen(ii)
+            airentots=airentots + airen(jmn*(imn+1)+ii)
+         end do 
+
+         do ii =1, imn+1
+            varn(ii,1,l) = totn/airentotn
+            varn(ii,jmn+1,l) = tots/airentots
+         end do 
+
+      ENDDO
+           
+
+c---------------------------------------------------------------
+c  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST  TEST 
+      if (firsttest) then
+      pi=2.*asin(1.)
+      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-1)*(imn+1))/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-1)*(imn+1)),airetest(ii,jj)
+             aire_ok = .false.
+         end if
+       end do
+      end do
+      if (aire_ok) write(*,*) 'INTERP. HORIZ. : AIRES OK'
+      endif
+
+c FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST  FIN TEST
+c --------------------------------------------------------------------
+
+
+        return
+        end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_vert.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_vert.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/interp_vert.F	(revision 57)
@@ -0,0 +1,70 @@
+c******************************************************
+      SUBROUTINE   interp_vert(varo,varn,lmo,lmn,apso,bpso,
+     &             aps,bps,ps,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 Modif pour coordonnees hybrides FF (03/2003)
+c**********************************************************
+
+      IMPLICIT NONE
+
+c   Declarations:
+c ==============
+c
+c  ARGUMENTS
+c  """""""""
+
+       integer lmo ! dimensions ancienne couches (input)
+       integer lmn ! dimensions nouvelle couches (input)
+
+       real apso(lmo),bpso(lmo)! anciennes coord hybrides midlayer (input)
+       real aps(lmn), bps(lmn)! nouvelles coord hybrides (midlayer) (input)
+
+       integer Nhoriz ! nombre de point horizontale (input)
+       real ps(nhoriz) !pression de surface (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
+       REAL sigmo(lmo) ! niveau sigma des variables dans les anciennes coord
+       REAL sigmn(lmn) ! niveau sigma des variables dans les nouvelles coord
+
+c run
+c ====
+
+      do n=1,Nhoriz
+        do ln=1,lmn
+            sigmn(ln)=aps(ln)/ps(n)+bps(ln)
+        end do
+        do lo=1,lmo
+            sigmo(lo)=apso(lo)/ps(n)+bpso(lo)
+        end do
+
+        do ln=1,lmn
+           if (sigmn(ln).ge.sigmo(1))then
+             varn(n,ln) =  varo(n,1)  
+           else if (sigmn(ln).le.sigmo(lmo)) then
+             varn(n,ln) =  varo(n,lmo)
+           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))
+                   varn(n,ln)=varo(n,lo) +coef*(varo(n,lo+1)-varo(n,lo))
+                end if
+              end do           
+           end if
+         end do
+
+      end do
+
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_gam.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_gam.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_gam.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rot.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rot.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rot.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rotgam.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rotgam.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/laplacien_rotgam.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lect_start_archive.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lect_start_archive.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lect_start_archive.F	(revision 57)
@@ -0,0 +1,1067 @@
+
+      SUBROUTINE lect_start_archive(date,tsurf,tsoil,emis,q2,
+     .     t,ucov,vcov,ps,co2ice,h,phisold_newgrid,q,qsurf,nid)
+c=======================================================================
+c
+c
+c   Auteur:    05/1997 , 12/2003 : coord hybride  FF
+c   ------
+c
+c
+c   Objet:     Lecture des variables d'un fichier "start_archive"
+c              Plus besoin de régler ancienne valeurs grace
+c              a l'allocation dynamique de memoire (Yann Wanherdrick)
+c
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "surfdat.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "logic.h"
+#include "description.h"
+#include "ener.h"
+#include "temps.h"
+#include "lmdstd.h"
+#include "netcdf.inc"
+
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Variables dimension du fichier "ini"
+c------------------------------------
+      INTEGER   imold,jmold,lmold,nqold
+
+c et autres:
+c----------
+      INTEGER lnblnk
+      EXTERNAL lnblnk
+
+c Variables pour les lectures des fichiers "ini" 
+c--------------------------------------------------
+      INTEGER sizei,timelen,dimid
+      INTEGER length
+      parameter (length = 100)
+      INTEGER tab0
+      INTEGER isoil,iq,iqmax
+      CHARACTER*2   str2
+
+      REAL dimfirst(4) ! tableau contenant les 1ers elements des dimensions
+
+      REAL dimlast(4) ! tableau contenant les derniers elements des dimensions
+
+      REAL dimcycl(4) ! tableau contenant les periodes des dimensions
+      CHARACTER*120 dimsource
+      CHARACTER*16 dimname
+      CHARACTER*80 dimtitle
+      CHARACTER*40 dimunits
+      INTEGER   dimtype
+
+      INTEGER dimord(4)  ! tableau contenant l''ordre
+      data dimord /1,2,3,4/ ! de sortie des dimensions
+
+      INTEGER vardim(4)
+      REAL date
+      INTEGER   memo
+      character (len=50) :: tmpname
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL h(iip1,jjp1,llm),ps(iip1,jjp1)
+      REAL q(iip1,jjp1,llm,nqmx),qtot(iip1,jjp1,llm)
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+
+c!-*-
+      integer klatdat,klongdat
+      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx)
+      REAL emis(ngridmx)
+      REAL q2(ngridmx,nlayermx+1),qsurf(ngridmx,nqmx)
+c     REAL phisfi(ngridmx)
+
+      INTEGER i,j,l
+      INTEGER nid,nvarid
+c     REAL year_day,periheli,aphelie,peri_day
+c     REAL obliquit,z0,emin_turb,lmixmin
+c     REAL emissiv,emisice(2),albedice(2),tauvis
+c     REAL iceradius(2) , dtemisice(2)
+
+      EXTERNAL RAN1
+      REAL RAN1
+      EXTERNAL geopot,inigeom
+      integer ierr
+      integer ismin
+      external ismin
+      CHARACTER*80 datapath
+      integer, dimension(4) :: start,count
+
+c Variable nouvelle grille naturelle au point scalaire
+c------------------------------------------------------
+      real us(iip1,jjp1,llm),vs(iip1,jjp1,llm)
+      REAL phisold_newgrid(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx)
+      real co2iceS(iip1,jjp1),emisS(iip1,jjp1)
+      REAL q2S(iip1,jjp1,llm+1),qsurfS(iip1,jjp1,nqmx)
+
+      real ptotal, co2icetotal
+
+c Var intermediaires : vent naturel, mais pas coord scalaire
+c-----------------------------------------------------------
+      real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
+
+
+c Variable de l'ancienne grille 
+c---------------------------------------------------------
+
+      real, dimension(:), allocatable :: timelist
+      real, dimension(:), allocatable :: rlonuold, rlatvold
+      real, dimension(:), allocatable :: rlonvold, rlatuold
+      real, dimension(:), allocatable :: apsold,bpsold
+      real, dimension(:,:,:), allocatable :: uold,vold,told,q2old
+      real, dimension(:,:,:), allocatable :: tsoilold,qsurfold
+      real, dimension(:,:), allocatable :: psold,phisold
+      real, dimension(:,:), allocatable :: co2iceold,tsurfold
+      real, dimension(:,:), allocatable :: emisold
+      real, dimension(:,:,:,:), allocatable :: qold
+
+      real tab_cntrl(100)
+
+      real ptotalold, co2icetotalold
+
+c Variable intermediaires iutilise pour l'extrapolation verticale 
+c----------------------------------------------------------------
+      real, dimension(:,:,:), allocatable :: var,varp1 
+
+c=======================================================================
+
+c Catching the axis lenghts for dynamic memory allocation 
+
+      ierr= NF_INQ_DIMID(nid,"Time",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"temps",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
+
+      ierr= NF_INQ_DIMID(nid,"latitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlatu",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,jmold)
+      jmold=jmold-1
+
+      ierr= NF_INQ_DIMID(nid,"longitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"rlonv",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,imold)
+      imold=imold-1
+
+      ierr= NF_INQ_DIMID(nid,"altitude",dimid)
+      if (ierr.ne.NF_NOERR) then
+         ierr= NF_INQ_DIMID(nid,"sig_s",dimid)
+      endif
+      ierr= NF_INQ_DIMLEN(nid,dimid,lmold)
+
+      nqold=0
+      do
+         write(str2,'(i2.2)') nqold+1
+         ierr= NF_INQ_VARID(nid,'q'//str2,dimid)
+!        write(*,*) 'q'//str2
+         if (ierr.eq.NF_NOERR) then
+            nqold=nqold+1
+         else
+            exit
+         endif
+      enddo
+
+      write(*,*) "Start_archive dimensions:"
+      write(*,*) "longitude: ",imold
+      write(*,*) "latitude: ",jmold
+      write(*,*) "altitude: ",lmold
+      write(*,*) "tracers: ",nqold
+      write(*,*) "time lenght: ",timelen
+      write(*,*) 
+
+      allocate(timelist(timelen))
+      allocate(rlonuold(imold+1), rlatvold(jmold))
+      allocate(rlonvold(imold+1), rlatuold(jmold+1))
+      allocate (apsold(lmold),bpsold(lmold))
+      allocate(uold(imold+1,jmold+1,lmold))
+      allocate(vold(imold+1,jmold+1,lmold))
+      allocate(told(imold+1,jmold+1,lmold))
+      allocate(psold(imold+1,jmold+1))
+      allocate(phisold(imold+1,jmold+1))
+      allocate(qold(imold+1,jmold+1,lmold,nqmx))
+      allocate(co2iceold(imold+1,jmold+1))
+      allocate(tsurfold(imold+1,jmold+1))
+      allocate(emisold(imold+1,jmold+1))
+      allocate(q2old(imold+1,jmold+1,lmold+1))
+      allocate(tsoilold(imold+1,jmold+1,nsoilmx))
+      allocate(qsurfold(imold+1,jmold+1,nqmx))
+
+      allocate(var (imold+1,jmold+1,llm))
+      allocate(varp1 (imold+1,jmold+1,llm+1))
+
+      write(*,*) 'q2',ngridmx,nlayermx+1
+      write(*,*) 'q2S',iip1,jjp1,llm+1
+      write(*,*) 'q2old',imold+1,jmold+1,lmold+1
+ 
+C-----------------------------------------------------------------------
+c Lecture du tableau des parametres du run 
+c     (pour  la lecture ulterieure de "ptotalold" et "co2icetotalold")
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Lect_start_archive: champ <controle> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+c
+      tab0 = 50
+
+c-----------------------------------------------------------------------
+c Lecture des longitudes et latitudes
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "rlonv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonv>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatu> est absent"
+         CALL abort
+      ENDIF 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlonu", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlonu> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <rlatv> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <rlatv>"
+         CALL abort
+      ENDIF
+c
+
+c-----------------------------------------------------------------------
+c Lecture des niveaux verticaux
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "aps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <aps> est absent"
+         apsold=0
+         PRINT*, "<aps> set to 0"
+      ELSE
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apsold)
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, apsold)
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Lecture echouee pour <aps>"
+         ENDIF
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "bps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <bps> est absent"
+         PRINT*, "It must be an old start_archive, lets look for sig_s"
+         ierr = NF_INQ_VARID (nid, "sig_s", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "Nothing to do..."
+            CALL abort
+         ENDIF
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpsold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, bpsold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <bps>"
+         CALL abort
+      END IF
+
+
+c-----------------------------------------------------------------------
+c Lecture geopotentiel au sol
+c-----------------------------------------------------------------------
+c
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <phisinit> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <phisinit>"
+         CALL abort
+      ENDIF
+
+C-----------------------------------------------------------------------
+c   lecture de "ptotalold" et "co2icetotalold"
+c-----------------------------------------------------------------------
+      ptotalold = tab_cntrl(tab0+49)
+      co2icetotalold = tab_cntrl(tab0+50)
+ 
+c-----------------------------------------------------------------------
+c   Lecture du temps et choix
+c-----------------------------------------------------------------------
+ 
+c  lecture du temps
+c
+      ierr = NF_INQ_DIMID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_DIMID (nid, "temps", nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: Le champ <Time> est absent"
+            CALL abort
+         endif
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         ierr = NF_INQ_VARID (nid, "temps", nvarid)
+      endif 
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, timelist)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, timelist)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <Time>"
+         CALL abort
+      ENDIF
+c
+      write(*,*)
+      write(*,*)
+      write(*,*) 'Differentes dates des etats initiaux stockes:'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      pi=2.*ASIN(1.)
+      do i=1,timelen
+c       call solarlong(timelist(i),sollong(i))
+c       sollong(i) = sollong(i)*180./pi
+        write(*,*) 'etat initial au jour martien' ,int(timelist(i))
+c       write(*,6) nint(timelist(i)),nint(mod(timelist(i),669)),
+c    .    sollong(i)
+      end do
+
+   6  FORMAT(i7,i7,f9.3)
+ 
+      write(*,*)
+      write(*,*) 'Choix de la date'
+ 123  read(*,*,iostat=ierr) date
+      if(ierr.ne.0) goto 123
+      memo = 0
+      do i=1,timelen
+        if (date.eq.int(timelist(i))) then
+            memo = i
+        endif
+      end do
+ 
+      if (memo.eq.0) then
+        write(*,*)
+        write(*,*)
+        write(*,*) 'He alors... Y sait pas lire !?!'
+        write(*,*)
+        write(*,*) 'Differentes dates des etats initiaux stockes:'
+        write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+        do i=1,timelen
+          write(*,*) 'etat initial au jour martien' ,nint(timelist(i))
+c         write(*,6) nint(timelist(i)),nint(mod(timelist(i),669))
+        end do
+        goto 123
+      endif
+ 
+c-----------------------------------------------------------------------
+c Lecture des champs 2D (co2ice, emis,ps,tsurf,Tg[10], q2surf)
+c-----------------------------------------------------------------------
+ 
+      start=(/1,1,memo,0/)
+      count=(/imold+1,jmold+1,1,0/)
+       
+      ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <co2ice> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,co2iceold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,co2iceold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <co2ice>"
+         PRINT*, NF_STRERROR(ierr)
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "emis", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <emis> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,emisold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,emisold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <emis>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "ps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <ps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,psold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,psold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <ps>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid, "tsurf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <tsurf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,tsurfold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,tsurfold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <tsurf>"
+         CALL abort
+      ENDIF
+c
+      do isoil=1,nsoilmx
+         write(str2,'(i2.2)') isoil
+c
+         ierr = NF_INQ_VARID (nid, "Tg"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .              Le champ <","Tg"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     .          tsoilold(1,1,isoil))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     .          tsoilold(1,1,isoil))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .            Lecture echouee pour <","Tg"//str2,">"
+            CALL abort
+         ENDIF
+c
+      end do
+
+c
+      ierr = NF_INQ_VARID (nid, "q2surf", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2surf> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2surf>"
+         CALL abort
+      ENDIF
+c
+      write (*,*) "rlonuold,rlatvold"
+      write (*,*) rlonuold
+      write (*,*) rlatvold
+      write (*,*)
+c
+
+c tracers: the 2 last ones are kept the 2 last one. 
+c the others keep their rank.
+c -------------------------------------------
+      
+      do iq=1,nqmx
+        call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+      enddo
+
+      iq=nqold
+        write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "qsurf"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Le champ <","qsurf"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     .          qsurfold(1,1,nqmx))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     .          qsurfold(1,1,nqmx))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","qsurf"//str2,">"
+            write (*,*) 'qsurf'//str2,' set to 0'
+            call initial0((jmold+1)*(imold+1), qsurfold(1,1,nqmx))
+         ENDIF
+
+      if ((nqold.gt.1).and.(nqmx.gt.1)) then
+        iq=nqold-1
+        write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "qsurf"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Le champ <","qsurf"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     .          qsurfold(1,1,nqmx-1))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     .          qsurfold(1,1,nqmx-1))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","qsurf"//str2,">"
+            write (*,*) 'qsurf'//str2,' set to 0'
+            call initial0((jmold+1)*(imold+1), qsurfold(1,1,nqmx-1))
+         ENDIF
+      endif
+
+      if (nqold.gt.2) then
+       do  iq = 1, nqold-2
+       if (iq.lt.nqmx-1) then
+         write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "qsurf"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Le champ <","qsurf"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,
+     .          qsurfold(1,1,iq))
+#else
+         ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,
+     .          qsurfold(1,1,iq))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","qsurf"//str2,">"
+            write (*,*) 'qsurf'//str2,' set to 0'
+            call initial0((jmold+1)*(imold+1), qsurfold(1,1,iq))
+         ENDIF
+       end if
+       end do
+      end if
+
+c-----------------------------------------------------------------------
+c	Lecture des champs 3D (t,u,v, q2atm,q)
+c-----------------------------------------------------------------------
+
+      start=(/1,1,1,memo/)
+      count=(/imold+1,jmold+1,lmold,1/)
+
+c
+      ierr = NF_INQ_VARID (nid,"temp", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <temp> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, count, told)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid, start, count, told)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <temp>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"u", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <u> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,uold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,uold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <u>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"v", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <v> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,vold)
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,vold)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <v>"
+         CALL abort
+      ENDIF
+c
+      ierr = NF_INQ_VARID (nid,"q2atm", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Le champ <q2atm> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,count,q2old(1,1,2))
+#else
+      ierr = NF_GET_VARA_REAL(nid, nvarid,start,count,q2old(1,1,2))
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "lect_start_archive: Lecture echouee pour <q2atm>"
+         CALL abort
+      ENDIF
+c
+
+c tracers: the 2 last ones are kept the 2 last one. 
+c the others keep their rank.
+c -------------------------------------------
+      
+      do iq=1,nqmx
+         call initial0((jmold+1)*(imold+1)*lmold,qold(1,1,1,iq) )
+      enddo
+
+      iq=nqold
+        write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "q"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive:
+     .               Le champ <","q"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr= NF_GET_VARA_DOUBLE(nid,nvarid,start,count,qold(1,1,1,nqmx))
+#else
+         ierr= NF_GET_VARA_REAL(nid,nvarid,start,count,qold(1,1,1,nqmx))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","q"//str2,">"
+            write (*,*) 'q'//str2,' set to 1.E-30'
+            do l=1,lmold
+              do j=1,jmold+1
+                do i=1,imold+1
+                   qold(1,1,1,nqmx)=1.e-30
+                end do
+              end do
+            end do
+
+         ENDIF
+
+      if ((nqold.gt.1).and.(nqmx.gt.1)) then
+        iq=nqold-1
+        write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "q"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive:
+     .               Le champ <","q"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr= NF_GET_VARA_DOUBLE(nid,nvarid,start,count,
+     .                            qold(1,1,1,nqmx-1))
+#else
+         ierr= NF_GET_VARA_REAL(nid,nvarid,start,count,
+     .                            qold(1,1,1,nqmx-1))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","q"//str2,">"
+            write (*,*) 'q'//str2,' set to 1.E-30'
+            do l=1,lmold
+              do j=1,jmold+1
+                do i=1,imold+1
+                   qold(1,1,1,nqmx-1)=1.e-30
+                end do
+              end do
+            end do
+
+         ENDIF
+      endif
+
+      if (nqold.gt.2) then
+       do  iq = 1, nqold-2
+       if (iq.lt.nqmx-1) then
+         write(str2,'(i2.2)') iq
+         ierr = NF_INQ_VARID (nid, "q"//str2, nvarid)
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive:
+     .               Le champ <","q"//str2,"> est absent"
+            CALL abort
+         ENDIF
+#ifdef NC_DOUBLE
+         ierr= NF_GET_VARA_DOUBLE(nid,nvarid,start,count,qold(1,1,1,iq))
+#else
+         ierr= NF_GET_VARA_REAL(nid,nvarid,start,count,qold(1,1,1,iq))
+#endif
+         IF (ierr .NE. NF_NOERR) THEN
+            PRINT*, "lect_start_archive: 
+     .               Lecture echouee pour <","q"//str2,">"
+            write (*,*) 'q'//str2,' set to 1.E-30 '
+            do l=1,lmold
+              do j=1,jmold+1
+                do i=1,imold+1
+                   qold(1,1,1,iq)=1.e-30
+                end do
+              end do
+            end do
+
+         ENDIF
+       end if
+       end do
+      end if
+
+c Chemin pour trouver les donnees de surface (albedo, relief, th.inertia...)
+c -------------------------------------------------------------------------
+
+      datapath = '/users/forget/gcm/data_mars_gcm'
+
+
+c=======================================================================
+c   INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables
+c=======================================================================
+c  Interpolation horizontale puis passage dans la grille physique pour 
+c  les variables physique 
+c  Interpolation verticale puis horizontale pour chaque variable 3D
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c	Variable 2d :
+c-----------------------------------------------------------------------
+c Relief 
+      call interp_horiz (phisold,phisold_newgrid,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c Glace CO2
+      call interp_horiz (co2iceold,co2ices,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c Temperature de surface
+      call interp_horiz (tsurfold,tsurfs,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,tsurfs,tsurf)
+c     write(44,*) 'tsurf', tsurf
+
+c Temperature du sous-sol
+      call interp_horiz(tsoilold,tsoils,
+     &                  imold,jmold,iim,jjm,nsoilmx,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (nsoilmx,iim+1,jjm+1,ngridmx,tsoils,tsoil)
+c     write(45,*) 'tsoil',tsoil
+
+c Emissivite de la surface
+      call interp_horiz (emisold,emiss,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,emiss,emis)
+c     write(46,*) 'emis',emis
+c-----------------------------------------------------------------------
+c	Traitement special de la pression au sol :
+c-----------------------------------------------------------------------
+
+c  Extrapolation la pression dans la nouvelle grille
+      call interp_horiz(psold,ps,imold,jmold,iim,jjm,1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+
+c-----------------------------------------------------------------------
+c	On assure la conservation de la masse de l'atmosphere + calottes
+c-----------------------------------------------------------------------
+
+      ptotal =  0.
+      co2icetotal = 0.
+      DO j=1,jjp1
+         DO i=1,iim
+            ptotal=ptotal+ps(i,j)*aire(i,j)/g
+            co2icetotal = co2icetotal + co2iceS(i,j)*aire(i,j)
+         END DO
+      END DO
+
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de l atm :',ptotalold
+      write(*,*)'Nouvelle grille: masse de l atm :',ptotal
+      write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold 
+      write(*,*)
+      write(*,*)'Ancienne grille: masse de la glace CO2:',co2icetotalold
+      write(*,*)'Nouvelle grille: masse de la glace CO2:',co2icetotal
+      write(*,*)'Ratio new ice./old ice =',co2icetotal/co2icetotalold
+      write(*,*)
+
+
+      DO j=1,jjp1
+         DO i=1,iip1
+            ps(i,j)=ps(i,j) * ptotalold/ptotal
+         END DO
+      END DO
+
+      if ( co2icetotalold.gt.0.) then 
+         DO j=1,jjp1
+            DO i=1,iip1
+               co2iceS(i,j)=co2iceS(i,j) * co2icetotalold/co2icetotal
+            END DO
+         END DO
+      end if
+
+c-----------------------------------------------------------------------
+c	Variable 3d :
+c-----------------------------------------------------------------------
+      
+c temperatures atmospheriques
+      write (*,*) 'told ', told (1,jmold+1,1)  ! INFO
+      call interp_vert
+     &    (told,var,lmold,llm,apsold,bpsold,aps,bps,
+     &     psold,(imold+1)*(jmold+1))
+      write (*,*) 'var ', var (1,jmold+1,1)  ! INFO
+      call interp_horiz(var,t,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 't ', t(1,jjp1,1)  ! INFO
+
+c q2 : pbl wind variance
+      write (*,*) 'q2old ', q2old (1,2,1)  ! INFO
+      call interp_vert (q2old,varp1,lmold+1,llm+1,
+     &     apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      write (*,*) 'varp1 ', varp1 (1,2,1)  ! INFO
+      call interp_horiz(varp1,q2s,imold,jmold,iim,jjm,llm+1,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'q2s ', q2s (1,2,1)  ! INFO
+      call gr_dyn_fi (llm+1,iim+1,jjm+1,ngridmx,q2s,q2)
+      write (*,*) 'q2 ', q2 (1,2)  ! INFO
+c     write(47,*) 'q2',q2
+
+c calcul des champ de vent; passage en vent covariant
+      write (*,*) 'uold ', uold (1,2,1)  ! INFO
+      call interp_vert
+     & (uold,var,lmold,llm,apsold,bpsold,aps,bps,
+     &  psold,(imold+1)*(jmold+1))
+      write (*,*) 'var ', var (1,2,1)  ! INFO
+      call interp_horiz(var,us,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      write (*,*) 'us ', us (1,2,1)   ! INFO
+
+      call interp_vert
+     & (vold,var,lmold,llm,
+     &  apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+      call interp_horiz(var,vs,imold,jmold,iim,jjm,llm,
+     &                   rlonuold,rlatvold,rlonu,rlatv)
+      call scal_wind(us,vs,unat,vnat)
+      write (*,*) 'unat ', unat (1,2,1)    ! INFO
+      do l=1,llm
+        do j = 1, jjp1
+          do i=1,iip1
+            ucov( i,j,l ) = unat( i,j,l ) * cu(i,j)
+c           ucov( i,j,l ) = 0
+          end do
+        end do
+      end do 
+      write (*,*) 'ucov ', ucov (1,2,1)  ! INFO
+c     write(48,*) 'ucov',ucov
+      do l=1,llm
+        do j = 1, jjm
+          do i=1,iim
+            vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j)
+c           vcov( i,j,l ) = 0
+          end do
+          vcov( iip1,j,l ) = vcov( 1,j,l )
+        end do
+      end do
+c     write(49,*) 'ucov',vcov
+
+c traceurs surface
+      do iq = 1, nqmx
+            call interp_horiz(qsurfold(1,1,iq) ,qsurfs(1,1,iq),
+     &                  imold,jmold,iim,jjm,1,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+
+      call gr_dyn_fi (nqmx,iim+1,jjm+1,ngridmx,qsurfs,qsurf)
+
+c traceurs 3D
+      do  iq = 1, nqmx
+            call interp_vert(qold(1,1,1,iq),var,lmold,llm,
+     &        apsold,bpsold,aps,bps,psold,(imold+1)*(jmold+1))
+            call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm,
+     &                  rlonuold,rlatvold,rlonu,rlatv)
+      enddo
+cccccccccccccccccccccccccccccc      
+c  make sure that sum of q = 1      
+c dominent species is = 1 - sum(all other species)      
+cccccccccccccccccccccccccccccc      
+c     iqmax=1
+c     
+c     if (nqold.gt.10) then
+c      do l=1,llm
+c       do j=1,jjp1
+c         do i=1,iip1
+c          do iq=1,nqold
+c           if (q(i,j,l,iq).gt.q(i,j,l,iqmax)) then
+c             iqmax=iq
+c            endif
+c          enddo
+c          q(i,j,l,iqmax)=1.
+c          qtot(i,j,l)=0
+c          do iq=1,nqold
+c           if (iq.ne.iqmax) then        
+c             q(i,j,l,iqmax)=q(i,j,l,iqmax)-q(i,j,l,iq)        
+c           endif
+c          enddo !iq
+c          do iq=1,nqold
+c           qtot(i,j,l)=qtot(i,j,l)+q(i,j,l,iq)
+c            if (i.eq.1.and.j.eq.1.and.l.Eq.1) write(*,*)' qtot(i,j,l)',
+c     $    qtot(i,j,l)
+c          enddo !iq
+c         enddo !i   
+c        enddo !j   
+c      enddo !l  
+c     endif
+ccccccccccccccccccccccccccccccc
+
+c     Periodicite :
+      do  iq = 1, nqmx
+         do l=1, llm
+            do j = 1, jjp1
+               q(iip1,j,l,iq) = q(1,j,l,iq)
+            end do
+         end do
+      enddo
+      
+      call gr_dyn_fi (1,iim+1,jjm+1,ngridmx,co2ices,co2ice)
+
+c-----------------------------------------------------------------------
+c   Initialisation  h:	(passage de t -> h)
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         DO j=1,jjp1
+            DO i=1,iim
+               h(i,j,l) = t(i,j,l)*((ps(i,j)/preff)**kappa)
+            END DO
+            h(iip1,j,l) =  h(1,j,l)
+         END DO
+      END DO
+
+
+c***********************************************************************
+c***********************************************************************
+c     Fin subroutine lecture ini
+c***********************************************************************
+c***********************************************************************
+
+      deallocate(timelist)
+      deallocate(rlonuold, rlatvold)
+      deallocate(rlonvold, rlatuold)
+      deallocate(apsold,bpsold)
+      deallocate(uold)
+      deallocate(vold)
+      deallocate(told)
+      deallocate(psold)
+      deallocate(phisold)
+      deallocate(qold)
+      deallocate(co2iceold)
+      deallocate(tsurfold)
+      deallocate(emisold)
+      deallocate(q2old)
+      deallocate(tsoilold)
+      deallocate(qsurfold)
+      deallocate(var,varp1)
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lectflux.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lectflux.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/lectflux.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/logic.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/logic.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/logic.h	(revision 57)
@@ -0,0 +1,10 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'logic.h'
+
+      COMMON/logic/ purmats,physic,forward,leapf,apphys,grireg,
+     *  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus,hybrid
+
+      LOGICAL purmats,physic,forward,leapf,apphys,grireg,statcl,conser,
+     * apdiss,apdelq,saison,ecripar,fxyhypb,ysinus,hybrid
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbar.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbar.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbar.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbarxy.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbarxy.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massbarxy.F	(revision 57)
@@ -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 l = 1 , llm
+c
+         DO 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 )
+         ENDDO
+
+c    ....  correction pour     massebxy( iip1,j )  ........
+
+CDIR$ IVDEP
+
+         DO ij = iip1, ip1jm, iip1
+            massebxy( ij,l ) = massebxy( ij - iim,l )
+         ENDDO
+
+      ENDDO
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massdair.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massdair.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/massdair.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/minmax.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/minmax.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/minmax.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multipl.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multipl.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multipl.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multscal.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multscal.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/multscal.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/netcdf.inc
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/netcdf.inc	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/netcdf.inc	(revision 57)
@@ -0,0 +1,1312 @@
+!
+! netcdf version 3 fortran interface:
+!
+
+!
+! external netcdf data types:
+!
+      integer nf_byte
+      integer nf_int1
+      integer nf_char
+      integer nf_short
+      integer nf_int2
+      integer nf_int
+      integer nf_float
+      integer nf_real
+      integer nf_double
+
+      parameter (nf_byte = 1)
+      parameter (nf_int1 = nf_byte)
+      parameter (nf_char = 2)
+      parameter (nf_short = 3)
+      parameter (nf_int2 = nf_short)
+      parameter (nf_int = 4)
+      parameter (nf_float = 5)
+      parameter (nf_real = nf_float)
+      parameter (nf_double = 6)
+
+!
+! default fill values:
+!
+      integer           nf_fill_byte
+      integer           nf_fill_int1
+      integer           nf_fill_char
+      integer           nf_fill_short
+      integer           nf_fill_int2
+      integer           nf_fill_int
+      real              nf_fill_float
+      real              nf_fill_real
+      doubleprecision   nf_fill_double
+
+      parameter (nf_fill_byte = -127)
+      parameter (nf_fill_int1 = nf_fill_byte)
+      parameter (nf_fill_char = 0)
+      parameter (nf_fill_short = -32767)
+      parameter (nf_fill_int2 = nf_fill_short)
+      parameter (nf_fill_int = -2147483647)
+      parameter (nf_fill_float = 9.9692099683868690e+36)
+      parameter (nf_fill_real = nf_fill_float)
+      parameter (nf_fill_double = 9.9692099683868690e+36)
+
+!
+! mode flags for opening and creating a netcdf dataset:
+!
+      integer nf_nowrite
+      integer nf_write
+      integer nf_clobber
+      integer nf_noclobber
+      integer nf_fill
+      integer nf_nofill
+      integer nf_lock
+      integer nf_share
+      integer nf_sizehint_default
+      integer nf_align_chunk
+
+      parameter (nf_nowrite = 0)
+      parameter (nf_write = 1)
+      parameter (nf_clobber = 0)
+      parameter (nf_noclobber = 4)
+      parameter (nf_fill = 0)
+      parameter (nf_nofill = 256)
+      parameter (nf_lock = 1024)
+      parameter (nf_share = 2048)
+      parameter (nf_sizehint_default = 0)
+      parameter (nf_align_chunk = -1)
+
+!
+! size argument for defining an unlimited dimension:
+!
+      integer nf_unlimited
+      parameter (nf_unlimited = 0)
+
+!
+! global attribute id:
+!
+      integer nf_global
+      parameter (nf_global = 0)
+
+!
+! implementation limits:
+!
+      integer nf_max_dims
+      integer nf_max_attrs
+      integer nf_max_vars
+      integer nf_max_name
+      integer nf_max_var_dims
+
+      parameter (nf_max_dims = 100)
+      parameter (nf_max_attrs = 2000)
+      parameter (nf_max_vars = 2000)
+      parameter (nf_max_name = 128)
+      parameter (nf_max_var_dims = nf_max_dims)
+
+!
+! error codes:
+!
+      integer nf_noerr
+      integer nf_ebadid
+      integer nf_eexist
+      integer nf_einval
+      integer nf_eperm
+      integer nf_enotindefine
+      integer nf_eindefine
+      integer nf_einvalcoords
+      integer nf_emaxdims
+      integer nf_enameinuse
+      integer nf_enotatt
+      integer nf_emaxatts
+      integer nf_ebadtype
+      integer nf_ebaddim
+      integer nf_eunlimpos
+      integer nf_emaxvars
+      integer nf_enotvar
+      integer nf_eglobal
+      integer nf_enotnc
+      integer nf_ests
+      integer nf_emaxname
+      integer nf_eunlimit
+      integer nf_enorecvars
+      integer nf_echar
+      integer nf_eedge
+      integer nf_estride
+      integer nf_ebadname
+      integer nf_erange
+      integer nf_enomem
+
+      parameter (nf_noerr = 0)
+      parameter (nf_ebadid = -33)
+      parameter (nf_eexist = -35)
+      parameter (nf_einval = -36)
+      parameter (nf_eperm = -37)
+      parameter (nf_enotindefine = -38)
+      parameter (nf_eindefine = -39)
+      parameter (nf_einvalcoords = -40)
+      parameter (nf_emaxdims = -41)
+      parameter (nf_enameinuse = -42)
+      parameter (nf_enotatt = -43)
+      parameter (nf_emaxatts = -44)
+      parameter (nf_ebadtype = -45)
+      parameter (nf_ebaddim = -46)
+      parameter (nf_eunlimpos = -47)
+      parameter (nf_emaxvars = -48)
+      parameter (nf_enotvar = -49)
+      parameter (nf_eglobal = -50)
+      parameter (nf_enotnc = -51)
+      parameter (nf_ests = -52)
+      parameter (nf_emaxname = -53)
+      parameter (nf_eunlimit = -54)
+      parameter (nf_enorecvars = -55)
+      parameter (nf_echar = -56)
+      parameter (nf_eedge = -57)
+      parameter (nf_estride = -58)
+      parameter (nf_ebadname = -59)
+      parameter (nf_erange = -60)
+      parameter (nf_enomem = -61)
+
+!
+! error handling modes:
+!
+      integer  nf_fatal
+      integer nf_verbose
+
+      parameter (nf_fatal = 1)
+      parameter (nf_verbose = 2)
+
+!
+! miscellaneous routines:
+!
+      character*80   nf_inq_libvers
+      external       nf_inq_libvers
+
+      character*80   nf_strerror
+!                         (integer             ncerr)
+      external       nf_strerror
+
+      logical        nf_issyserr
+!                         (integer             ncerr)
+      external       nf_issyserr
+
+!
+! control routines:
+!
+      integer         nf_inq_base_pe
+!                         (integer             ncid,
+!                          integer             pe)
+      external        nf_inq_base_pe
+
+      integer         nf_set_base_pe
+!                         (integer             ncid,
+!                          integer             pe)
+      external        nf_set_base_pe
+
+      integer         nf_create
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             ncid)
+      external        nf_create
+
+      integer         nf__create
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             initialsz,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__create
+
+      integer         nf__create_mp
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             initialsz,
+!                          integer             basepe,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__create_mp
+
+      integer         nf_open
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             ncid)
+      external        nf_open
+
+      integer         nf__open
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__open
+
+      integer         nf__open_mp
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             basepe,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__open_mp
+
+      integer         nf_set_fill
+!                         (integer             ncid,
+!                          integer             fillmode,
+!                          integer             old_mode)
+      external        nf_set_fill
+
+      integer         nf_redef
+!                         (integer             ncid)
+      external        nf_redef
+
+      integer         nf_enddef
+!                         (integer             ncid)
+      external        nf_enddef
+
+      integer         nf__enddef
+!                         (integer             ncid,
+!                          integer             h_minfree,
+!                          integer             v_align,
+!                          integer             v_minfree,
+!                          integer             r_align)
+      external        nf__enddef
+
+      integer         nf_sync
+!                         (integer             ncid)
+      external        nf_sync
+
+      integer         nf_abort
+!                         (integer             ncid)
+      external        nf_abort
+
+      integer         nf_close
+!                         (integer             ncid)
+      external        nf_close
+
+      integer         nf_delete
+!                         (character*(*)       ncid)
+      external        nf_delete
+
+!
+! general inquiry routines:
+!
+
+      integer         nf_inq
+!                         (integer             ncid,
+!                          integer             ndims,
+!                          integer             nvars,
+!                          integer             ngatts,
+!                          integer             unlimdimid)
+      external        nf_inq
+
+      integer         nf_inq_ndims
+!                         (integer             ncid,
+!                          integer             ndims)
+      external        nf_inq_ndims
+
+      integer         nf_inq_nvars
+!                         (integer             ncid,
+!                          integer             nvars)
+      external        nf_inq_nvars
+
+      integer         nf_inq_natts
+!                         (integer             ncid,
+!                          integer             ngatts)
+      external        nf_inq_natts
+
+      integer         nf_inq_unlimdim
+!                         (integer             ncid,
+!                          integer             unlimdimid)
+      external        nf_inq_unlimdim
+
+!
+! dimension routines:
+!
+
+      integer         nf_def_dim
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             len,
+!                          integer             dimid)
+      external        nf_def_dim
+
+      integer         nf_inq_dimid
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             dimid)
+      external        nf_inq_dimid
+
+      integer         nf_inq_dim
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name,
+!                          integer             len)
+      external        nf_inq_dim
+
+      integer         nf_inq_dimname
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name)
+      external        nf_inq_dimname
+
+      integer         nf_inq_dimlen
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          integer             len)
+      external        nf_inq_dimlen
+
+      integer         nf_rename_dim
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name)
+      external        nf_rename_dim
+
+!
+! general attribute routines:
+!
+
+      integer         nf_inq_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len)
+      external        nf_inq_att
+
+      integer         nf_inq_attid
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             attnum)
+      external        nf_inq_attid
+
+      integer         nf_inq_atttype
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype)
+      external        nf_inq_atttype
+
+      integer         nf_inq_attlen
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             len)
+      external        nf_inq_attlen
+
+      integer         nf_inq_attname
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             attnum,
+!                          character(*)        name)
+      external        nf_inq_attname
+
+      integer         nf_copy_att
+!                         (integer             ncid_in,
+!                          integer             varid_in,
+!                          character(*)        name,
+!                          integer             ncid_out,
+!                          integer             varid_out)
+      external        nf_copy_att
+
+      integer         nf_rename_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        curname,
+!                          character(*)        newname)
+      external        nf_rename_att
+
+      integer         nf_del_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_del_att
+
+!
+! attribute put/get routines:
+!
+
+      integer         nf_put_att_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             len,
+!                          character(*)        text)
+      external        nf_put_att_text
+
+      integer         nf_get_att_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          character(*)        text)
+      external        nf_get_att_text
+
+      integer         nf_put_att_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_att_int1
+
+      integer         nf_get_att_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_att_int1
+
+      integer         nf_put_att_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_att_int2
+
+      integer         nf_get_att_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_att_int2
+
+      integer         nf_put_att_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          integer             ivals(1))
+      external        nf_put_att_int
+
+      integer         nf_get_att_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             ivals(1))
+      external        nf_get_att_int
+
+      integer         nf_put_att_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          real                rvals(1))
+      external        nf_put_att_real
+
+      integer         nf_get_att_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          real                rvals(1))
+      external        nf_get_att_real
+
+      integer         nf_put_att_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          double              dvals(1))
+      external        nf_put_att_double
+
+      integer         nf_get_att_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          double              dvals(1))
+      external        nf_get_att_double
+
+!
+! general variable routines:
+!
+
+      integer         nf_def_var
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             datatype,
+!                          integer             ndims,
+!                          integer             dimids(1),
+!                          integer             varid)
+      external        nf_def_var
+
+      integer         nf_inq_var
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             datatype,
+!                          integer             ndims,
+!                          integer             dimids(1),
+!                          integer             natts)
+      external        nf_inq_var
+
+      integer         nf_inq_varid
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             varid)
+      external        nf_inq_varid
+
+      integer         nf_inq_varname
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_inq_varname
+
+      integer         nf_inq_vartype
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             xtype)
+      external        nf_inq_vartype
+
+      integer         nf_inq_varndims
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ndims)
+      external        nf_inq_varndims
+
+      integer         nf_inq_vardimid
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             dimids(1))
+      external        nf_inq_vardimid
+
+      integer         nf_inq_varnatts
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             natts)
+      external        nf_inq_varnatts
+
+      integer         nf_rename_var
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_rename_var
+
+      integer         nf_copy_var
+!                         (integer             ncid_in,
+!                          integer             varid,
+!                          integer             ncid_out)
+      external        nf_copy_var
+
+!
+! entire variable put/get routines:
+!
+
+      integer         nf_put_var_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        text)
+      external        nf_put_var_text
+
+      integer         nf_get_var_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        text)
+      external        nf_get_var_text
+
+      integer         nf_put_var_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_var_int1
+
+      integer         nf_get_var_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_var_int1
+
+      integer         nf_put_var_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_var_int2
+
+      integer         nf_get_var_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_var_int2
+
+      integer         nf_put_var_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ivals(1))
+      external        nf_put_var_int
+
+      integer         nf_get_var_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ivals(1))
+      external        nf_get_var_int
+
+      integer         nf_put_var_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          real                rvals(1))
+      external        nf_put_var_real
+
+      integer         nf_get_var_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          real                rvals(1))
+      external        nf_get_var_real
+
+      integer         nf_put_var_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          doubleprecision     dvals(1))
+      external        nf_put_var_double
+
+      integer         nf_get_var_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          doubleprecision     dvals(1))
+      external        nf_get_var_double
+
+!
+! single variable put/get routines:
+!
+
+      integer         nf_put_var1_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          character*1         text)
+      external        nf_put_var1_text
+
+      integer         nf_get_var1_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          character*1         text)
+      external        nf_get_var1_text
+
+      integer         nf_put_var1_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int1_t           i1val)
+      external        nf_put_var1_int1
+
+      integer         nf_get_var1_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int1_t           i1val)
+      external        nf_get_var1_int1
+
+      integer         nf_put_var1_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int2_t           i2val)
+      external        nf_put_var1_int2
+
+      integer         nf_get_var1_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int2_t           i2val)
+      external        nf_get_var1_int2
+
+      integer         nf_put_var1_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          integer             ival)
+      external        nf_put_var1_int
+
+      integer         nf_get_var1_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          integer             ival)
+      external        nf_get_var1_int
+
+      integer         nf_put_var1_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          real                rval)
+      external        nf_put_var1_real
+
+      integer         nf_get_var1_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          real                rval)
+      external        nf_get_var1_real
+
+      integer         nf_put_var1_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          doubleprecision     dval)
+      external        nf_put_var1_double
+
+      integer         nf_get_var1_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          doubleprecision     dval)
+      external        nf_get_var1_double
+
+!
+! variable array put/get routines:
+!
+
+      integer         nf_put_vara_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          character(*)        text)
+      external        nf_put_vara_text
+
+      integer         nf_get_vara_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          character(*)        text)
+      external        nf_get_vara_text
+
+      integer         nf_put_vara_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_vara_int1
+
+      integer         nf_get_vara_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_vara_int1
+
+      integer         nf_put_vara_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_vara_int2
+
+      integer         nf_get_vara_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_vara_int2
+
+      integer         nf_put_vara_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             ivals(1))
+      external        nf_put_vara_int
+
+      integer         nf_get_vara_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             ivals(1))
+      external        nf_get_vara_int
+
+      integer         nf_put_vara_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          real                rvals(1))
+      external        nf_put_vara_real
+
+      integer         nf_get_vara_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          real                rvals(1))
+      external        nf_get_vara_real
+
+      integer         nf_put_vara_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_vara_double
+
+      integer         nf_get_vara_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_vara_double
+
+!
+! strided variable put/get routines:
+!
+
+      integer         nf_put_vars_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          character(*)        text)
+      external        nf_put_vars_text
+
+      integer         nf_get_vars_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          character(*)        text)
+      external        nf_get_vars_text
+
+      integer         nf_put_vars_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_vars_int1
+
+      integer         nf_get_vars_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_vars_int1
+
+      integer         nf_put_vars_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_vars_int2
+
+      integer         nf_get_vars_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_vars_int2
+
+      integer         nf_put_vars_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             ivals(1))
+      external        nf_put_vars_int
+
+      integer         nf_get_vars_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             ivals(1))
+      external        nf_get_vars_int
+
+      integer         nf_put_vars_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          real                rvals(1))
+      external        nf_put_vars_real
+
+      integer         nf_get_vars_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          real                rvals(1))
+      external        nf_get_vars_real
+
+      integer         nf_put_vars_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_vars_double
+
+      integer         nf_get_vars_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_vars_double
+
+!
+! mapped variable put/get routines:
+!
+
+      integer         nf_put_varm_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          character(*)        text)
+      external        nf_put_varm_text
+
+      integer         nf_get_varm_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          character(*)        text)
+      external        nf_get_varm_text
+
+      integer         nf_put_varm_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_varm_int1
+
+      integer         nf_get_varm_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_varm_int1
+
+      integer         nf_put_varm_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_varm_int2
+
+      integer         nf_get_varm_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_varm_int2
+
+      integer         nf_put_varm_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          integer             ivals(1))
+      external        nf_put_varm_int
+
+      integer         nf_get_varm_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          integer             ivals(1))
+      external        nf_get_varm_int
+
+      integer         nf_put_varm_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          real                rvals(1))
+      external        nf_put_varm_real
+
+      integer         nf_get_varm_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          real                rvals(1))
+      external        nf_get_varm_real
+
+      integer         nf_put_varm_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_varm_double
+
+      integer         nf_get_varm_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_varm_double
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! begin netcdf 2.4 backward compatibility:
+!
+
+!      
+! functions in the fortran interface
+!
+      integer nccre
+      integer ncopn
+      integer ncddef
+      integer ncdid
+      integer ncvdef
+      integer ncvid
+      integer nctlen
+      integer ncsfil
+
+      external nccre
+      external ncopn
+      external ncddef
+      external ncdid
+      external ncvdef
+      external ncvid
+      external nctlen
+      external ncsfil
+
+
+      integer ncrdwr
+      integer nccreat
+      integer ncexcl
+      integer ncindef
+      integer ncnsync
+      integer nchsync
+      integer ncndirty
+      integer nchdirty
+      integer nclink
+      integer ncnowrit
+      integer ncwrite
+      integer ncclob
+      integer ncnoclob
+      integer ncglobal
+      integer ncfill
+      integer ncnofill
+      integer maxncop
+      integer maxncdim
+      integer maxncatt
+      integer maxncvar
+      integer maxncnam
+      integer maxvdims
+      integer ncnoerr
+      integer ncebadid
+      integer ncenfile
+      integer nceexist
+      integer nceinval
+      integer nceperm
+      integer ncenotin
+      integer nceindef
+      integer ncecoord
+      integer ncemaxds
+      integer ncename
+      integer ncenoatt
+      integer ncemaxat
+      integer ncebadty
+      integer ncebadd
+      integer ncests
+      integer nceunlim
+      integer ncemaxvs
+      integer ncenotvr
+      integer nceglob
+      integer ncenotnc
+      integer ncfoobar
+      integer ncsyserr
+      integer ncfatal
+      integer ncverbos
+      integer ncentool
+
+
+!
+! netcdf data types:
+!
+      integer ncbyte
+      integer ncchar
+      integer ncshort
+      integer nclong
+      integer ncfloat
+      integer ncdouble
+
+      parameter(ncbyte = 1)
+      parameter(ncchar = 2)
+      parameter(ncshort = 3)
+      parameter(nclong = 4)
+      parameter(ncfloat = 5)
+      parameter(ncdouble = 6)
+
+!     
+!     masks for the struct nc flag field; passed in as 'mode' arg to
+!     nccreate and ncopen.
+!     
+
+!     read/write, 0 => readonly 
+      parameter(ncrdwr = 1)
+!     in create phase, cleared by ncendef 
+      parameter(nccreat = 2)
+!     on create destroy existing file 
+      parameter(ncexcl = 4)
+!     in define mode, cleared by ncendef 
+      parameter(ncindef = 8)
+!     synchronise numrecs on change (x'10')
+      parameter(ncnsync = 16)
+!     synchronise whole header on change (x'20')
+      parameter(nchsync = 32)
+!     numrecs has changed (x'40')
+      parameter(ncndirty = 64)  
+!     header info has changed (x'80')
+      parameter(nchdirty = 128)
+!     prefill vars on endef and increase of record, the default behavior
+      parameter(ncfill = 0)
+!     do not fill vars on endef and increase of record (x'100')
+      parameter(ncnofill = 256)
+!     isa link (x'8000')
+      parameter(nclink = 32768)
+
+!     
+!     'mode' arguments for nccreate and ncopen
+!     
+      parameter(ncnowrit = 0)
+      parameter(ncwrite = ncrdwr)
+      parameter(ncclob = nf_clobber)
+      parameter(ncnoclob = nf_noclobber)
+
+!     
+!     'size' argument to ncdimdef for an unlimited dimension
+!     
+      integer ncunlim
+      parameter(ncunlim = 0)
+
+!     
+!     attribute id to put/get a global attribute
+!     
+      parameter(ncglobal  = 0)
+
+!     
+!     advisory maximums:
+!     
+      parameter(maxncop = 32)
+      parameter(maxncdim = 100)
+      parameter(maxncatt = 2000)
+      parameter(maxncvar = 2000)
+!     not enforced 
+      parameter(maxncnam = 128)
+      parameter(maxvdims = maxncdim)
+
+!     
+!     global netcdf error status variable
+!     initialized in error.c
+!     
+
+!     no error 
+      parameter(ncnoerr = nf_noerr)
+!     not a netcdf id 
+      parameter(ncebadid = nf_ebadid)
+!     too many netcdfs open 
+      parameter(ncenfile = -31)   ! nc_syserr
+!     netcdf file exists && ncnoclob
+      parameter(nceexist = nf_eexist)
+!     invalid argument 
+      parameter(nceinval = nf_einval)
+!     write to read only 
+      parameter(nceperm = nf_eperm)
+!     operation not allowed in data mode 
+      parameter(ncenotin = nf_enotindefine )   
+!     operation not allowed in define mode 
+      parameter(nceindef = nf_eindefine)   
+!     coordinates out of domain 
+      parameter(ncecoord = nf_einvalcoords)
+!     maxncdims exceeded 
+      parameter(ncemaxds = nf_emaxdims)
+!     string match to name in use 
+      parameter(ncename = nf_enameinuse)   
+!     attribute not found 
+      parameter(ncenoatt = nf_enotatt)
+!     maxncattrs exceeded 
+      parameter(ncemaxat = nf_emaxatts)
+!     not a netcdf data type 
+      parameter(ncebadty = nf_ebadtype)
+!     invalid dimension id 
+      parameter(ncebadd = nf_ebaddim)
+!     ncunlimited in the wrong index 
+      parameter(nceunlim = nf_eunlimpos)
+!     maxncvars exceeded 
+      parameter(ncemaxvs = nf_emaxvars)
+!     variable not found 
+      parameter(ncenotvr = nf_enotvar)
+!     action prohibited on ncglobal varid 
+      parameter(nceglob = nf_eglobal)
+!     not a netcdf file 
+      parameter(ncenotnc = nf_enotnc)
+      parameter(ncests = nf_ests)
+      parameter (ncentool = nf_emaxname) 
+      parameter(ncfoobar = 32)
+      parameter(ncsyserr = -31)
+
+!     
+!     global options variable. used to determine behavior of error handler.
+!     initialized in lerror.c
+!     
+      parameter(ncfatal = 1)
+      parameter(ncverbos = 2)
+
+!
+!     default fill values.  these must be the same as in the c interface.
+!
+      integer filbyte
+      integer filchar
+      integer filshort
+      integer fillong
+      real filfloat
+      doubleprecision fildoub
+
+      parameter (filbyte = -127)
+      parameter (filchar = 0)
+      parameter (filshort = -32767)
+      parameter (fillong = -2147483647)
+      parameter (filfloat = 9.9692099683868690e+36)
+      parameter (fildoub = 9.9692099683868690e+36)
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/newstart.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/newstart.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/newstart.F	(revision 57)
@@ -0,0 +1,955 @@
+C======================================================================
+      PROGRAM newstart
+c=======================================================================
+c
+c
+c   Auteur:   Christophe Hourdin/Francois Forget/Yann Wanherdrick
+c   ------
+c             Derniere modif : 12/03
+c
+c
+c   Objet:  Create or modify the initial state for the LMD Mars GCM
+c   -----           (fichiers NetCDF start et startfi)
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "surfdat.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+#include "planete.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "logic.h"
+#include "description.h"
+#include "ener.h"
+#include "temps.h"
+#include "lmdstd.h"
+#include "comdissnew.h"
+#include "clesph0.h"
+#include "serre.h"
+#include "netcdf.inc"
+
+c=======================================================================
+c   Declarations
+c=======================================================================
+
+c Variables dimension du fichier "start_archive"
+c------------------------------------
+      CHARACTER	relief*3
+
+c et autres:
+c----------
+      INTEGER lnblnk
+      EXTERNAL lnblnk
+
+c Variables pour les lectures NetCDF des fichiers "start_archive" 
+c--------------------------------------------------
+      INTEGER nid_dyn, nid_fi,nid,nvarid
+      INTEGER size
+      INTEGER length
+      parameter (length = 100)
+      INTEGER tab0
+      INTEGER   NB_ETATMAX
+      parameter (NB_ETATMAX = 100)
+
+      REAL  date
+      REAL p_rad,p_omeg,p_g,p_mugaz,p_daysec
+
+c Variable histoire 
+c------------------
+      REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants
+      REAL phis(iip1,jjp1)
+      REAL q(iip1,jjp1,llm,nqmx)               ! champs advectes
+
+c autre variables dynamique nouvelle grille
+c------------------------------------------
+      REAL pks(iip1,jjp1)
+      REAL w(iip1,jjp1,llm+1)
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
+      REAL dh(ip1jmp1,llm),dp(ip1jmp1)
+      REAL phi(iip1,jjp1,llm)
+
+      integer klatdat,klongdat
+      PARAMETER (klatdat=180,klongdat=360)
+
+c Physique sur grille scalaire 
+c----------------------------
+      real zmeaS(iip1,jjp1),zstdS(iip1,jjp1)
+      real zsigS(iip1,jjp1),zgamS(iip1,jjp1),ztheS(iip1,jjp1)
+
+c variable physique
+c------------------
+      REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx)
+      REAL emis(ngridmx),qsurf(ngridmx,nqmx)
+      REAL q2(ngridmx,nlayermx+1)
+      REAL rnaturfi(ngridmx)
+      real alb(iip1,jjp1),albfi(ngridmx)
+      real ith(iip1,jjp1),ithfi(ngridmx)
+      REAL latfi(ngridmx),lonfi(ngridmx),airefi(ngridmx)
+
+      INTEGER i,j,l,idum,ig
+      real mugaz ! masse molaire de l''atmosphere
+
+      EXTERNAL iniconst,geopot,inigeom
+      integer ierr, nbetat
+      integer ismin
+      external ismin
+
+c Variable nouvelle grille naturelle au point scalaire
+c------------------------------------------------------
+      REAL p(iip1,jjp1)
+      REAL t(iip1,jjp1,llm)
+      real phisold_newgrid(iip1,jjp1)
+      REAL :: teta(iip1, jjp1, llm)
+      REAL :: pk(iip1,jjp1,llm)
+      REAL :: pkf(iip1,jjp1,llm)
+      REAL :: ps(iip1, jjp1)
+      REAL :: masse(iip1,jjp1,llm)
+      REAL :: xpn,xps,xppn(iim),xpps(iim)
+      REAL :: p3d(iip1, jjp1, llm+1)
+      REAL :: beta(iip1,jjp1,llm)
+      REAL dteta(ip1jmp1,llm)
+
+c Variable de l'ancienne grille 
+c------------------------------
+      real time
+      real tab_cntrl(100)
+      real tab_cntrl_bis(100)
+
+c variables diverses
+c-------------------
+      real choix_1
+      character*80      fichnom
+      integer Lmodif,iq,thermo
+      character modif*20
+      real z_reel(iip1,jjp1)
+      real tsud,albsud,alb_bb,ith_bb,Tiso
+      real ptoto,pcap,patm,airetot,ptotn,patmn
+      real ssum
+      character*1 yes
+      logical :: flagiso=.false. ,  flagps0=.false.
+      real val
+
+      INTEGER :: itau
+
+c sortie visu pour les champs dynamiques
+c---------------------------------------
+      INTEGER :: visuid
+      real :: time_step,t_ops,t_wrt
+      CHARACTER*80 :: visu_file
+
+      cpp    = 744.499 ! au lieu de 1004.70885 (Terre)
+      preff  = 610.    ! au lieu de 101325. (Terre)
+      pa= 20           ! au lieu de 500 (Terre)
+
+c=======================================================================
+c   Choix du fichier de demarrage a modifier
+c=======================================================================
+
+      write(*,*) 'From which kind of files do you want to create new',
+     .  'start and startfi files'
+      write(*,*) '    0 - from a file start_archive'
+      write(*,*) '    1 - from files start and startfi'
+ 
+c-----------------------------------------------------------------------
+c   Ouverture des fichiers a modifier (start ou start_archive)
+c-----------------------------------------------------------------------
+
+      DO
+         read(*,*,iostat=ierr) choix_1
+         if ((choix_1 /= 0).OR.(choix_1 /=1)) EXIT
+      ENDDO
+
+c     Ouverture de start_archive
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start_archive.dat and ./start_archive.dic'
+        write(*,*)
+        fichnom = 'start_archive.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening: ',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+        tab0 = 50 
+        Lmodif = 1
+
+c     OU Ouverture de start
+c     ~~~~~~~~~~~~~~~~~~~~~
+      else
+        write(*,*) 'Creating start files from:'
+        write(*,*) './start.nc and ./startfi.nc'
+        write(*,*)
+        fichnom = 'start.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_dyn)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening:  ',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+ 
+        fichnom = 'startfi.nc'
+        ierr = NF_OPEN (fichnom, NF_NOWRITE,nid_fi)
+        IF (ierr.NE.NF_NOERR) THEN
+          write(6,*)' Problem opening:  ',fichnom
+          write(6,*)' ierr = ', ierr
+          CALL ABORT
+        ENDIF
+
+        tab0 = 0 
+        Lmodif = 0
+
+      endif
+
+c-----------------------------------------------------------------------
+c Lecture du tableau des parametres du run (pour la dynamique)
+c-----------------------------------------------------------------------
+
+      if (choix_1.eq.0) then
+
+        write(*,*) 'reading tab_cntrl START_ARCHIVE'
+c
+        ierr = NF_INQ_VARID (nid, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl)
+#endif
+c
+      else if (choix_1.eq.1) then
+
+        write(*,*) 'reading tab_cntrl START'
+c
+        ierr = NF_INQ_VARID (nid_dyn, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_dyn, nvarid, tab_cntrl)
+#else
+        ierr = NF_GET_VAR_REAL(nid_dyn, nvarid, tab_cntrl)
+#endif
+c
+        write(*,*) 'reading tab_cntrl STARTFI'
+c
+        ierr = NF_INQ_VARID (nid_fi, "controle", nvarid)
+#ifdef NC_DOUBLE
+        ierr = NF_GET_VAR_DOUBLE(nid_fi, nvarid, tab_cntrl_bis)
+#else
+        ierr = NF_GET_VAR_REAL(nid_fi, nvarid, tab_cntrl_bis)
+#endif
+c
+        do i=1,50
+          tab_cntrl(i+50)=tab_cntrl_bis(i)
+        enddo
+      write(*,*) 'printing tab_cntrl', tab_cntrl
+      do i=1,100
+        write(*,*) i,tab_cntrl(i)
+      enddo
+      
+      endif
+c-----------------------------------------------------------------------
+c		Initialisation des constantes dynamique
+c-----------------------------------------------------------------------
+
+      kappa = tab_cntrl(9) 
+      etot0 = tab_cntrl(12)
+      ptot0 = tab_cntrl(13)
+      ztot0 = tab_cntrl(14)
+      stot0 = tab_cntrl(15)
+      ang0 = tab_cntrl(16)
+      write(*,*) "kappa,etot0,ptot0,ztot0,stot0,ang0"
+      write(*,*) kappa,etot0,ptot0,ztot0,stot0,ang0
+
+c-----------------------------------------------------------------------
+c   Lecture du tab_cntrl et initialisation des constantes physiques
+c  - pour start:  Lmodif = 0 => pas de modifications possibles
+c                  (modif dans le tabfi de readfi + loin)
+c  - pour start_archive:  Lmodif = 1 => modifications possibles
+c-----------------------------------------------------------------------
+      if (choix_1.eq.0) then
+         call tabfi (nid,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_mugaz,p_daysec,time)
+      else if (choix_1.eq.1) then
+         call tabfi (nid_fi,Lmodif,tab0,day_ini,lllm,p_rad,
+     .            p_omeg,p_g,p_mugaz,p_daysec,time)
+      endif
+
+      rad = p_rad
+      omeg = p_omeg
+      g = p_g
+      mugaz = p_mugaz
+      daysec = p_daysec
+      write(*,*) 'aire',aire
+
+
+c=======================================================================
+c  INITIALISATIONS DIVERSES
+c=======================================================================
+
+      day_step=180
+      CALL defrun_new( 99, .TRUE. )
+      CALL iniconst 
+      CALL inigeom
+      idum=-1
+      idum=0
+
+c Initialisation coordonnees /aires
+c -------------------------------
+
+      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)
+
+
+c=======================================================================
+c  Lecture des fichiers (start ou start_archive)
+c=======================================================================
+
+      if (choix_1.eq.0) then
+
+        write(*,*) 'Reading file START_ARCHIVE'
+        CALL lect_start_archive(date,tsurf,tsoil,emis,q2,
+     .   t,ucov,vcov,ps,co2ice,teta,phisold_newgrid,q,qsurf,nid)
+        
+        ierr= NF_CLOSE(nid)
+
+      else if (choix_1.eq.1) then !  c'est l'appel a tabfi de phyeta0 qui
+                                  !  permet de changer les valeurs du 
+                                  !  tab_cntrl Lmodif=1
+        tab0=0
+        Lmodif=1 ! Lmodif set to 1 to allow modifications in phyeta0                           
+        write(*,*) 'Reading file START'
+        fichnom = 'start.nc'
+        CALL dynetat0(fichnom,nqmx,vcov,ucov,teta,q,masse,
+     .       ps,phis,time)
+
+        write(*,*) 'Reading file STARTFI'
+        fichnom = 'startfi.nc'
+        CALL phyetat0 (fichnom,tab0,Lmodif,nsoilmx,nqmx,
+     .        day_ini,time,
+     .        tsurf,tsoil,emis,q2,qsurf,co2ice)
+        
+        do i=1,ngridmx
+          albfi(i) = albedodat(i)
+          ithfi(i) = inertiedat(i)
+        enddo
+c       save old topography
+          do j=1,jjp1
+            do i=1,iip1
+               phisold_newgrid(i,j)=phis(i,j)         
+            enddo
+          enddo
+      else 
+        CALL exit(1)
+      endif
+
+      dtvr   = daysec/FLOAT(day_step)
+      dtphys   = dtvr * FLOAT(iphysiq)
+
+c=======================================================================
+c   lecture topographie, albedo, inertie thermique, relief sous-maille
+c=======================================================================
+
+      if (choix_1.ne.1) then  ! pour ne pas avoir besoin du fichier 
+                              ! surface.dat dans le cas des start
+
+c do while((relief(1:3).ne.'mol').AND.(relief(1:3).ne.'pla'))
+c       write(*,*)
+c       write(*,*) 'choix du relief (mola,pla)'
+c       write(*,*) '(Topographie MGS MOLA, plat)'
+c       read(*,fmt='(a3)') relief
+        relief="mola"
+c     enddo
+
+      CALL datareadnc(relief,phis,alb,ith,zmeaS,zstdS,zsigS,zgamS,
+     .          ztheS)
+
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zmeaS,zmea)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zstdS,zstd)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zsigS,zsig)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,zgamS,zgam)
+      CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ztheS,zthe)
+
+      endif
+
+c=======================================================================
+c 
+c=======================================================================
+ 
+ 888  continue
+
+      write(*,*)
+      write(*,*)
+      write(*,*) 'Other possible changes :'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      write(*,*)
+      write(*,*) 'flat : no topography ("aquaplanet")'
+      write(*,*) 'bilball : uniform albedo and thermal inertia '
+      write(*,*) 'coldspole : cold subsurface and high albedo at S.pole'
+      write(*,*) 'q=0 : ALL tracer =zero'
+      write(*,*) 'q=x : give a specific uniform value to one tracer'
+      write(*,*) 'ini_q : tracers initialisation for chemistry, water an
+     $d ice   '
+      write(*,*) 'ini_q-H2O : tracers initialisation for chemistry and 
+     $ice '
+      write(*,*) 'ini_q-iceH2O : tracers initialisation for chemistry on
+     $ly '
+      write(*,*) 'noglacier : Remove tropical H2O ice if |lat|<45'
+      write(*,*) 'watercapn : H20 ice on permanent N polar cap '
+      write(*,*) 'watercaps : H20 ice on permanent S polar cap '
+      write(*,*) 'wetstart  : start with a wet atmosphere'
+      write(*,*) 'isotherm : Isothermal Temperatures, wind set to zero'
+      write(*,*) 'co2ice=0 : remove CO2 polar cap'
+      write(*,*) 'ptot : change total pressure'
+
+
+      do while(modif(1:1).ne.'hello')
+        write(*,*)
+        write(*,*) 'Changes to perform ?'
+        write(*,*) '   (enter keyword or return to end)'
+        write(*,*)
+
+        read(*,fmt='(a20)') modif
+        if (modif(1:1) .eq. ' ') goto 999
+        write(*,*)
+        write(*,*) modif(1:lnblnk(modif)) , ' : '
+
+c       'flat : no topography ("aquaplanet")'
+c       -------------------------------------
+        if (modif(1:lnblnk(modif)) .eq. 'flat') then
+c         set topo to zero 
+          CALL initial0(ip1jmp1,z_reel)
+          CALL multscal(ip1jmp1,z_reel,g,phis)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,phis,phisfi)
+          write(*,*) 'topography set to zero.'
+          write(*,*) 'WARNING : the subgrid topography parameters',
+     &    ' were not set to zero ! => set calllott to F'                    
+
+c        Choice for surface pressure
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to choose homogeneous surface',
+     &                 'pressure (y) or let newstart interpolate ',
+     &                 ' the previous field  (n)?'
+             read(*,fmt='(a)') yes
+         end do
+         if (yes.eq.'y') then
+           flagps0=.true.
+           write(*,*) 'New value for ps (Pa) ?'
+ 201       read(*,*,iostat=ierr) patm
+            if(ierr.ne.0) goto 201
+             write(*,*)
+             write(*,*) ' new ps everywhere (Pa) = ', patm
+             write(*,*)
+             do j=1,jjp1
+               do i=1,iip1
+                 ps(i,j)=patm
+               enddo
+             enddo
+         end if
+
+c       bilball : albedo, inertie thermique uniforme
+c       --------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'bilball') then
+          write(*,*) 'constante albedo and iner.therm:'
+          write(*,*) 'New value for albedo (ex: 0.25) ?'
+ 101      read(*,*,iostat=ierr) alb_bb
+          if(ierr.ne.0) goto 101
+          write(*,*)
+          write(*,*) ' albedo uniform (new value):',alb_bb
+          write(*,*)
+
+          write(*,*) 'New value for iner.therm (ex: 247) ?'
+ 102      read(*,*,iostat=ierr) ith_bb
+          if(ierr.ne.0) goto 102
+          write(*,*) 'iner.therm uniform (new value):',ith_bb
+          DO j=1,jjp1
+             DO i=1,iip1
+                alb(i,j) = alb_bb
+                ith(i,j) = ith_bb
+             END DO
+          END DO
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,ith,ithfi)
+          CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+c       coldspole : sous-sol de la calotte sud toujours froid
+c       -----------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'coldspole') then
+          write(*,*)'nouvelle valeur de la temperature du',
+     &   'sous sol de la calotte permanente sud ? (ex: 141 K)'
+ 103      read(*,*,iostat=ierr) tsud
+          if(ierr.ne.0) goto 103
+          write(*,*)
+          write(*,*) ' nouvelle valeur de la temperature:',tsud
+c         nouvelle temperature sous la calotte permanente
+          do l=2,nsoilmx
+               tsoil(ngridmx,l) =  tsud
+          end do
+
+
+          write(*,*)'nouvelle valeur de l albedo',
+     &   'de la calotte permanente sud ? (ex: 0.75 K)'
+ 104      read(*,*,iostat=ierr) albsud
+          if(ierr.ne.0) goto 104
+          write(*,*)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c         Option 1:  Seul l'albedo du pole est modifié :    
+          albfi(ngridmx)=albsud
+          write(*,*) 'ig=',ngridmx,'   albedo perennial cap ',
+     &    albfi(ngridmx)
+
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~é 
+c          Option 2 A haute resolution : coordonnée de la vrai calotte ~    
+c           DO j=1,jjp1
+c             DO i=1,iip1
+c                ig=1+(j-2)*iim +i
+c                if(j.eq.1) ig=1
+c                if(j.eq.jjp1) ig=ngridmx
+c                if ((rlatu(j)*180./pi.lt.-84.).and.
+c     &            (rlatu(j)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.gt.-91.).and.
+c     &            (rlonv(i)*180./pi.lt.0.))         then
+cc    albedo de la calotte permanente fixe a albsud
+c                   alb(i,j)=albsud
+c                   write(*,*) 'lat=',rlatu(j)*180./pi,
+c     &                      ' lon=',rlonv(i)*180./pi
+cc     fin de la condition sur les limites de la calotte permanente
+c                end if
+c             ENDDO
+c          ENDDO
+c      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+c         CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,alb,albfi)
+
+
+c       ptot : Modification de la pression totale glace + atm actuelle
+c       --------------------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'ptot') then
+
+c         calcul de la pression totale glace + atm actuelle
+          patm=0.
+          airetot=0.
+          pcap=0.
+          DO j=1,jjp1
+             DO i=1,iim
+                ig=1+(j-2)*iim +i
+                if(j.eq.1) ig=1
+                if(j.eq.jjp1) ig=ngridmx
+                patm = patm + ps(i,j)*aire(i,j)
+                airetot= airetot + aire(i,j)
+                pcap = pcap + aire(i,j)*co2ice(ig)*g
+             ENDDO
+          ENDDO
+          ptoto = pcap + patm
+
+          print*,'Pression totale au sol actuelle (co2 ice + atm) ',
+     &       ptoto/airetot
+
+          print*,'nouvelle valeur?'
+          read(*,*) ptotn
+          ptotn=ptotn*airetot
+          patmn=ptotn-pcap
+          print*,'ptoto,patm,ptotn,patmn'
+          print*,ptoto,patm,ptotn,patmn
+          print*,'Facteur mult de la pression (atm only)', patmn/patm
+          do j=1,jjp1
+             do i=1,iip1
+                ps(i,j)=ps(i,j)*patmn/patm
+             enddo
+          enddo
+
+c        Correction pour la conservation des traceurs
+         yes=' '
+         do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*) 'Do you wish to conserve tracer total mass (y)',
+     &              ' or tracer mixing ratio (n) ?'
+             read(*,fmt='(a)') yes
+         end do
+
+         if (yes.eq.'y') then
+           write(*,*) 'OK : conservation of tracer total mass'
+           DO iq =1, nqmx
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=q(i,j,l,iq)*patm/patmn
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+          else
+            write(*,*) 'OK : conservation of tracer mixing ratio'
+          end if
+
+c       q=0 : traceurs a zero
+c       ---------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'q=0') then
+c          mise a 0 des q (traceurs)
+          write(*,*) 'Traceurs mis a 0 (1.E-30 en fait)'
+           DO iq =1, nqmx
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=1.e-30
+                  ENDDO
+               ENDDO
+             ENDDO
+           ENDDO
+
+c          mise a 0 des qsurf (traceurs a la surface)
+           DO iq =1, nqmx
+             DO ig=1,ngridmx   
+                 qsurf(ig,iq)=0.
+             ENDDO
+           ENDDO
+
+c       q=x : initialise tracer manually 
+c       --------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'q=x') then
+             write(*,*) 'Which tracer do you want to modify ?'
+             write(*,*) '(choose between 1 and ',nqmx,')'
+             read(*,*) iq 
+             write(*,*)'mixing ratio of tracer #',iq, ' ? (kg/kg)'
+             read(*,*) val
+             DO l=1,llm
+               DO j=1,jjp1
+                  DO i=1,iip1
+                    q(i,j,l,iq)=val
+                  ENDDO
+               ENDDO
+             ENDDO
+             write(*,*) 'SURFACE value of tracer #', iq , ' ? (kg/m2)'
+             read(*,*) val
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=val
+             ENDDO
+
+c       ini_q : traceurs initialises pour la chimie
+c       -----------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'ini_q') then
+c         For more than 32 layers, possible to initiate thermosphere only     
+          thermo=0
+          yes=' '
+          if (llm.gt.32) then 
+            do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*)'',
+     &     'initialisation for thermosphere only? (y/n)'
+            read(*,fmt='(a)') yes
+            if (yes.eq.'y') then
+            thermo=1 
+            else
+            thermo=0
+            endif
+            enddo  
+          endif
+          
+              call inichim_newstart(q,ps,sig,nqmx,latfi,lonfi,airefi,
+     $   thermo)
+          write(*,*) 'Especes chimiques initialisees'
+
+        if (thermo.eq.0) then 
+c          mise a 0 des qsurf (traceurs a la surface)
+           DO iq =1, nqmx
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=0.
+             ENDDO
+           ENDDO
+        endif   
+
+c       ini_q-H2O : idem sauf le dernier traceur (H2O)
+c       -----------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'ini_q-H2O') then
+          ! for more than 32 layers, possible to initiate thermosphere only     
+          thermo=0
+          yes=' '
+          if(llm.gt.32) then
+            do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*)'',
+     &      'initialisation for thermosphere only? (y/n)'
+            read(*,fmt='(a)') yes
+            if (yes.eq.'y') then 
+            thermo=1 
+            else
+            thermo=0
+            endif
+            enddo
+          endif
+              call inichim_newstart(q,ps,sig,nqmx-1,latfi,lonfi,airefi,
+     $   thermo)
+          write(*,*) 'Esp. chim. initialisees sauf derniere (H2O)'
+
+        if (thermo.eq.0) then 
+c          mise a 0 des qsurf (traceurs a la surface)
+           DO iq =1, nqmx-1
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=0.
+             ENDDO
+           ENDDO
+        endif
+
+c       ini_q-iceH2O : idem sauf ice et H2O
+c       -----------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'ini_q-iceH2O') then
+c         For more than 32 layers, possible to initiate thermosphere only     
+          thermo=0
+          yes=' '
+          if(llm.gt.32) then
+            do while ((yes.ne.'y').and.(yes.ne.'n'))
+            write(*,*)'',
+     &      'initialisation for thermosphere only? (y/n)'
+            read(*,fmt='(a)') yes
+            if (yes.eq.'y') then 
+            thermo=1 
+            else
+            thermo=0
+            endif
+            enddo
+          endif
+     
+         call inichim_newstart(q,ps,sig,nqmx-2,latfi,lonfi,airefi,
+     $   thermo)
+          write(*,*) 'Esp. chim. initialisees sauf ice et H2O'
+
+        if (thermo.eq.0) then 
+c          mise a 0 des qsurf (traceurs a la surface)
+           DO iq =1, nqmx-2
+             DO ig=1,ngridmx
+                 qsurf(ig,iq)=0.
+             ENDDO 
+           ENDDO
+        endif
+c      wetstart : wet atmosphere with a north to south gradient
+c      --------------------------------------------------------
+       else if (modif(1:lnblnk(modif)) .eq. 'wetstart') then
+          DO l=1,llm
+            DO j=1,jjp1
+              DO i=1,iip1
+                q(i,j,l,nqmx)=150.e-6 * (rlatu(j)+pi/2.) / pi
+              ENDDO
+            ENDDO
+          ENDDO
+
+         write(*,*) 'Water mass mixing ratio at north pole='
+     *               ,q(1,1,1,nqmx)
+         write(*,*) '---------------------------south pole='
+     *               ,q(1,jjp1,1,nqmx)
+
+c      noglacier : remove tropical water ice (to initialize high res sim)
+c      --------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'noglacier') then
+           do ig=1,ngridmx
+             j=(ig-2)/iim +2
+              if(ig.eq.1) j=1
+              write(*,*) 'OK: remove surface ice for |lat|<45'
+              if (abs(rlatu(j)*180./pi).lt.45.) then
+                   qsurf(ig,nqmx)=0.
+              end if
+           end do
+c      watercapn : H20 ice sur la calotte permanente nord
+c      --------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'watercapn') then
+           do ig=1,ngridmx
+             j=(ig-2)/iim +2
+              if(ig.eq.1) j=1
+              if (rlatu(j)*180./pi.gt.80.) then
+                   qsurf(ig,nqmx)=1.e5
+                   write(*,*) 'ig=',ig,'    H2O ice mass (kg/m2)= ',
+     &              qsurf(ig,nqmx)
+                   write(*,*)'     ==> Ice mesh South boundary (deg)= ',
+     &              rlatv(j)*180./pi
+                end if
+           enddo
+
+c      watercaps : H20 ice sur la calotte permanente sud
+c      -------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'watercaps') then
+           do ig=1,ngridmx
+               j=(ig-2)/iim +2
+               if(ig.eq.1) j=1
+               if (rlatu(j)*180./pi.lt.-80.) then
+                   qsurf(ig,nqmx)=1.e5
+                   write(*,*) 'ig=',ig,'   H2O ice mass (kg/m2)= ',
+     &              qsurf(ig,nqmx)
+                   write(*,*)'     ==> Ice mesh North boundary (deg)= ',
+     &              rlatv(j-1)*180./pi
+               end if
+           enddo
+
+c       isotherm : Temperatures isothermes et vents nuls
+c       ------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'isotherm') then
+
+          write(*,*)'Isothermal temperature of the atmosphere, 
+     &           surface and subsurface'
+          write(*,*) 'Value of THIS temperature ? :'
+ 203      read(*,*,iostat=ierr) Tiso
+          if(ierr.ne.0) goto 203
+
+          do ig=1, ngridmx
+            tsurf(ig) = Tiso
+          end do
+          do l=2,nsoilmx
+            do ig=1, ngridmx
+              tsoil(ig,l) = Tiso
+            end do
+          end do
+          flagiso=.true.
+          call initial0(llm*ip1jmp1,ucov)
+          call initial0(llm*ip1jm,vcov)
+          call initial0(ngridmx*(llm+1),q2)
+
+c       co2ice=0 : ellimination des calottes polaires de CO2'
+c       ------------------------------------------------
+        else if (modif(1:lnblnk(modif)) .eq. 'co2ice=0') then
+           do ig=1,ngridmx
+              co2ice(ig)=0
+              emis(ig)=emis(ngridmx/2)
+           end do
+        else
+          goto 888
+        end if
+      end do
+
+ 999  continue
+
+ 
+c=======================================================================
+c   Correction de la pression pour nouvelle grille (menu 0)
+c=======================================================================
+
+      if (flagps0.eq..false.) then
+        r = 1000.*8.31/mugaz
+
+        do j=1,jjp1
+          do i=1,iip1
+             ps(i,j) = ps(i,j) * 
+     .            exp((phisold_newgrid(i,j)-phis(i,j)) /
+     .                                  (t(i,j,1) * r))
+          end do
+        end do
+  
+c periodicite de ps en longitude
+        do j=1,jjp1
+          ps(1,j) = ps(iip1,j)
+        end do
+      end if
+
+c=======================================================================
+c=======================================================================
+
+c=======================================================================
+c    Initialisation de la physique / ecriture de newstartfi :
+c=======================================================================
+
+
+      CALL inifilr 
+      CALL pression(ip1jmp1, ap, bp, ps, p3d)
+
+c-----------------------------------------------------------------------
+c   Initialisation  pks:
+c-----------------------------------------------------------------------
+
+      CALL exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
+! Calcul de la temperature potentielle teta
+
+      if (flagiso) then
+          DO l=1,llm
+             DO j=1,jjp1
+                DO i=1,iim
+                   teta(i,j,l) = Tiso * cpp/pk(i,j,l)
+                ENDDO
+                teta (iip1,j,l)= teta (1,j,l)
+             ENDDO
+          ENDDO
+      else if (choix_1.eq.0) then
+         DO l=1,llm
+            DO j=1,jjp1
+               DO i=1,iim
+                  teta(i,j,l) = t(i,j,l) * cpp/pk(i,j,l)
+               ENDDO
+               teta (iip1,j,l)= teta (1,j,l)
+            ENDDO
+         ENDDO
+      endif
+
+C Calcul intermediaire
+c
+      if (choix_1.eq.0) then
+         CALL massdair( p3d, masse  )
+c
+         print *,' ALPHAX ',alphax
+
+         DO  l = 1, llm
+           DO  i    = 1, iim
+             xppn(i) = aire( i, 1   ) * masse(  i     ,  1   , l )
+             xpps(i) = aire( i,jjp1 ) * masse(  i     , jjp1 , l )
+           ENDDO
+             xpn      = SUM(xppn)/apoln
+             xps      = SUM(xpps)/apols
+           DO i   = 1, iip1
+             masse(   i   ,   1     ,  l )   = xpn
+             masse(   i   ,   jjp1  ,  l )   = xps
+           ENDDO
+         ENDDO
+      endif
+      phis(iip1,:) = phis(1,:)
+
+      CALL inidissip ( lstardis, nitergdiv, nitergrot, niterh,
+     *                tetagdiv, tetagrot , tetatemp  )
+      itau=0
+      if (choix_1.eq.0) then
+         day_ini=int(date)
+      endif
+c
+      CALL geopot  ( ip1jmp1, teta  , pk , pks,  phis  , phi   )
+
+      CALL caldyn0( itau,ucov,vcov,teta,ps,masse,pk,phis ,
+     *                phi,w, pbaru,pbarv,day_ini+time )
+c     CALL caldyn
+c    $  ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis ,
+c    $    phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, day_ini )
+
+      CALL dynredem0("restart.nc",day_ini,anneeref,phis,nqmx)
+      CALL dynredem1("restart.nc",0.0,vcov,ucov,teta,q,nqmx,masse,ps) 
+C
+C Ecriture etat initial physique
+C
+      call physdem1("restartfi.nc",lonfi,latfi,nsoilmx,nqmx,
+     .              dtphys,float(day_ini),
+     .              time,tsurf,tsoil,co2ice,emis,q2,qsurf,
+     .              airefi,albfi,ithfi,zmea,zstd,zsig,zgam,zthe)
+
+c=======================================================================
+c	Formats 
+c=======================================================================
+
+   1  FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lllm =',i4,2x,'lue sur le fichier demar
+     *rage est differente de la valeur parametree llm =',i4//)
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad_gam.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad_gam.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrad_gam.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgradst.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgradst.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgradst.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgraro2.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgraro2.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgraro2.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrarot.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrarot.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/nxgrarot.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/para_netcdf.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/para_netcdf.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/para_netcdf.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/paramet.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/paramet.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/paramet.h	(revision 57)
@@ -0,0 +1,19 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3)
+      PARAMETER( jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/pression.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/pression.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/pression.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ps_amontF
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ps_amontF	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ps_amontF	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/psextbar.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/psextbar.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/psextbar.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ran1.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ran1.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/ran1.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/readhead_NC.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/readhead_NC.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/readhead_NC.F	(revision 57)
@@ -0,0 +1,231 @@
+      SUBROUTINE readhead_NC (fichnom,
+     .           day0,
+     .           phis,constR)
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c  Adaptation à Mars : Yann Wanherdrick 
+c Objet: Lecture de l etat initial pour la physique
+c======================================================================
+#include "netcdf.inc"
+c====== includes de l ancien readhead ===
+#include "dimensions.h"
+#include "paramet.h"
+#include "temps.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "description.h"
+
+c======================================================================
+
+      CHARACTER*(*) fichnom
+      INTEGER nbsrf !Mars nbsrf a 1 au lieu de 4
+      PARAMETER (nbsrf=1) ! nombre de sous-fractions pour une maille
+
+      INTEGER radpas
+
+      REAL xmin, xmax
+c
+      INTEGER  i
+
+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
+      INTEGER day0
+      REAL phis(ip1jmp1),constR
+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
+        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*, 'readhead_NC: 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*, 'readhead_NC: Lecture echouee pour <controle>'
+         CALL abort
+      ENDIF
+
+
+c Info sur la Planete Mars pour la dynamique 
+      im         = tab_cntrl(1)
+      jm         = tab_cntrl(2)
+      lllm       = tab_cntrl(3)
+      day_ini    = tab_cntrl(4)
+      rad        = tab_cntrl(5)
+      omeg       = tab_cntrl(6)
+      g          = tab_cntrl(7)
+c      mugaz      = tab_cntrl(8)
+      cpp        =  744.499
+      kappa      = tab_cntrl(9)
+      daysec     = tab_cntrl(10)
+      dtvr       = tab_cntrl(11)
+      etot0      = tab_cntrl(12)
+      ptot0      = tab_cntrl(13)
+      ztot0      = tab_cntrl(14)
+      stot0      = tab_cntrl(15)
+      ang0       = tab_cntrl(16)
+c pas vrai pour diagfi, seulement pour start      preff      = tab_cntrl(18)
+      preff=610.
+      WRITE (*,*) 'readhead -     preff ' , preff 
+c
+
+      day0=day_ini
+
+      constR=kappa*cpp
+      WRITE (*,*) 'constR = ' , constR
+      r=constR
+      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*, "readhead_NC: 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*, "readhead_NC: Lecture echouee pour <rlonu>"
+         CALL abort
+      ENDIF
+                                                                       
+      ierr = NF_INQ_VARID (nid, "rlatv", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: 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*, "readhead_NC: Lecture echouee pour rlatv"
+         CALL abort
+      ENDIF
+
+      ierr = NF_GET_VAR_REAL(nid, nvarid, cv)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: Lecture echouee pour <cv>"
+         CALL abort
+      ENDIF
+c
+c Lecture des aires des mailles:
+c
+      ierr = NF_INQ_VARID (nid, "aire", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'readhead_NC: 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*, 'readhead_NC: Lecture echouee pour <aire>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(aire)
+      xmax = MAXVAL(aire)
+      PRINT*,'Aires des mailles <aire>:', xmin, xmax
+c
+c Lecture du geopotentiel au sol:
+c
+      ierr = NF_INQ_VARID (nid, "phisinit", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'readhead_NC: 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*, 'readhead_NC: Lecture echouee pour <phis>'
+         CALL abort
+      ENDIF
+c      PRINT*,'READHEAD_NC  Phis:',phis
+
+      ierr = NF_INQ_VARID (nid, "aps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: Le champ <aps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, aps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: Lecture echouee pour <aps>"
+         CALL abort
+      ENDIF
+
+      ierr = NF_INQ_VARID (nid, "bps", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: Le champ <bps> est absent"
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, bps)
+#endif
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "readhead_NC: Lecture echouee pour <bps>"
+         CALL abort
+      ENDIF
+
+   1  FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree iim =',i4//)
+   2  FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dema
+     *rrage est differente de la valeur parametree jjm =',i4//)
+   3  FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier demar
+     *rage est differente de la valeur parametree llm =',i4//)
+   4  FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier demar
+     *rage est differente de la valeur  dtinteg =',i4//)
+
+      
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat_nfil.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat_nfil.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotat_nfil.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatf.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatf.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatf.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatst.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatst.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/rotatst.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/scal_wind.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/scal_wind.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/scal_wind.F	(revision 57)
@@ -0,0 +1,55 @@
+      SUBROUTINE scal_wind(xus,xvs,xu,xv)
+c=======================================================================
+c
+c
+c   Subject:
+c   ------
+c On passe  les variable xus, xvs  aux points de vent u et v (xu et xv)
+c
+c=======================================================================
+      IMPLICIT NONE
+c-----------------------------------------------------------------------
+c   Declararations:
+c   ---------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+
+c   Arguments:
+c   ----------
+
+      REAL xu(iip1,jjp1,llm),xv(iip1,jjm,llm)
+      REAL xus(iip1,jjp1,llm), xvs (iip1,jjp1,llm)
+
+c   Local:
+c   ------
+
+      INTEGER i,j,l
+
+c-----------------------------------------------------------------------
+
+c   transport zonal:
+c   ----------------
+      DO l=1,llm
+        Do j=1,jjp1
+	      DO i=1,iim
+            xu(i,j,l)=0.5*(xus(i,j,l)+xus(i+1,j,l))
+	      ENDDO
+          xu(iip1,j,l)=xu(1,j,l)
+	    ENDDO
+      ENDDO
+
+
+c   Transport meridien:
+c   -------------------
+      DO l=1,llm
+         DO j=1,jjm
+           do i=1 ,iip1
+	         xv(i,j,l)=.5*(xvs(i,j,l)+xvs(i,j+1,l))
+           end do
+	     ENDDO
+	  ENDDO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/serre.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/serre.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/serre.h	(revision 57)
@@ -0,0 +1,6 @@
+c..include serre.h
+c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , 
+     ,  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc0.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc0.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sortvarc0.F	(revision 57)
@@ -0,0 +1,141 @@
+      SUBROUTINE sortvarc0
+     $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time ,
+     $ vcov)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:    P. Le Van
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   sortie des variables de controle
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "ener.h"
+#include "logic.h"
+#include "temps.h"
+
+c   Arguments:
+c   ----------
+
+      INTEGER itau
+      REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm)
+      REAL vcov(ip1jm,llm)
+      REAL ps(ip1jmp1),phis(ip1jmp1)
+      REAL vorpot(ip1jm,llm)
+      REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm)
+      REAL dp(ip1jmp1)
+      REAL time
+      REAL pk(ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm)
+      REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1)
+      REAL cosphi(ip1jm),omegcosp(ip1jm)
+      REAL dtvrs1j,rjour,heure,radsg,radomeg
+      REAL rday, massebxy(ip1jm,llm)
+      INTEGER  l, ij, imjmp1
+
+      EXTERNAL  filtreg, massbarxy
+c     EXTERNAL FLUSH
+      EXTERNAL   SSUM, SCOPY ,ismin,ismax
+      REAL       SSUM
+      integer  ismin,ismax
+
+c-----------------------------------------------------------------------
+
+       dtvrs1j   = dtvr/daysec
+       rjour     = FLOAT( INT( itau * dtvrs1j ))
+       heure     = ( itau*dtvrs1j-rjour ) * 24.
+       imjmp1    = iim * jjp1
+       IF(ABS(heure - 24.).LE.0.0001 ) heure = 0.
+c
+       CALL massbarxy ( masse, massebxy )
+
+c   .....  Calcul  de  rmsdpdt  .....
+
+       CALL multipl(ip1jmp1,dp,dp,ge)
+
+       rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+c
+       rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) 
+
+       CALL SCOPY( ijp1llm,bern,1,bernf,1 )
+       CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1)
+
+c   .....  Calcul du moment  angulaire   .....
+
+       radsg    = rad /g
+       radomeg  = rad * omeg
+c
+       DO ij=iip2,ip1jm
+          cosphi( ij ) = COS(rlatu((ij-1)/iip1+1))
+          omegcosp(ij) = radomeg   * cosphi(ij)
+       ENDDO
+
+c  ...  Calcul  de l'energie,de l'enstrophie,de l'entropie et de rmsv  .
+
+       DO l=1,llm
+          DO ij = 1,ip1jm
+             vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l)
+          ENDDO
+          ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1))
+
+          DO ij = 1,ip1jmp1
+             ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l)  +
+     s        bernf(ij,l)-phi(ij,l))
+          ENDDO
+          etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO   ij   = 1, ip1jmp1
+             ge(ij) = masse(ij,l)*teta(ij,l)
+          ENDDO
+          stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1)
+
+          DO ij=1,ip1jmp1
+             ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.)
+          ENDDO
+          rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1))
+
+          DO ij =iip2,ip1jm
+             ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) *
+     *               cosphi(ij)
+          ENDDO
+          angl(l) = radsg *
+     s    (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1))
+      ENDDO
+
+          DO ij=1,ip1jmp1
+            ge(ij)= ps(ij)*aire(ij)
+          ENDDO
+      ptot0  = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)
+      etot0  = SSUM(     llm, etotl, 1 )
+      ztot0  = SSUM(     llm, ztotl, 1 )
+      stot0  = SSUM(     llm, stotl, 1 )
+      rmsv   = SSUM(     llm, rmsvl, 1 )
+      ang0   = SSUM(     llm,  angl, 1 )
+
+      rday = day_ini
+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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/spline.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/spline.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/spline.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/splint.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/splint.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/splint.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.F	(revision 57)
@@ -0,0 +1,137 @@
+      subroutine sponge(ucov,vcov,h,pext,dt,mode)
+      implicit none
+#include "dimensions.h"
+#include "paramet.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "sponge.h"
+      real ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm)
+      real h(iip1,jjp1,llm),pext(iip1,jjp1)
+      real dt
+      real sig_s(llm) !sigma au milieu des couches
+      save sig_s
+
+c   Local:
+c   ------
+
+      REAL vm,um,hm,ptot(jjp1)
+      real cst(llm)
+      integer mode
+
+      INTEGER l,i,j,l0
+
+      real ssum
+
+      real echelle,zkm
+      logical firstcall
+      save firstcall,cst,l0
+      data firstcall/.true./
+
+      if (firstcall) then
+       do l=1,llm
+          sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+       enddo
+
+       IF (mode.eq.3) then
+         l0=llm-2
+         echelle=10.
+ 
+         PRINT*
+         print*,'sponge mode',mode
+         print*,'hsponge',hsponge
+         print*,'tetasponge n intervient pas'
+         print*,'Constantes de dissipations fixees comme les anglais'
+         print*,'Coeffs pour la couche en eponge'
+         print*,'Z (km)  tau'
+         cst(llm)=dt/(0.5*88775)
+         cst(llm-1)=dt/(88775)
+         cst(l0)=dt/(2*88775)
+         do l=l0,llm
+            zkm=-echelle*log(sig_s(l))
+            print*,zkm,dt/cst(l),cst(l)
+         enddo
+         firstcall=.false.
+         PRINT*
+       ELSE
+         l0=1
+         echelle=10.
+ 
+         PRINT*
+         print*,'sponge mode',mode
+         print*,'hsponge tetasponge ',hsponge,tetasponge
+         print*,'Coeffs pour la couche en eponge'
+         print*,'Z (km)  tau'
+         do l=1,llm
+            zkm=-echelle*log(sig_s(l))
+            cst(l)=.5*(1.+tanh((zkm-hsponge)/echelle))
+            cst(l)= max(tetasponge*1.e-15,cst(l))
+            print*,zkm,1./cst(l)*tetasponge,cst(l)*dt/tetasponge
+            cst(l)=cst(l)*dt/tetasponge
+         enddo
+         firstcall=.false.
+         PRINT*
+       ENDIF
+      endif
+
+c-----------------------------------------------------------------------
+c   calcul de la dissipation:
+c   -------------------------
+
+      do j=1,jjp1
+         ptot(j)=ssum(iim,pext(1,j),1)
+      enddo
+ 
+c   temperature potentielle
+      do l=l0,llm
+         do j=1,jjp1
+            hm=0.
+            do i=1,iim
+               hm=hm+h(i,j,l)*pext(i,j)
+            enddo
+            hm=hm/ptot(j)
+            do i=1,iim
+               h(i,j,l)=h(i,j,l)-cst(l)*(h(i,j,l)-hm)
+            enddo
+            h(iip1,j,l)=h(1,j,l)
+         enddo
+      enddo
+
+c   vent zonal
+      do l=l0,llm
+         do j=2,jjm
+            um=0.
+            if(mode.ge.1) then
+               do i=1,iim
+                  um=um+0.5*ucov(i,j,l)*(pext(i,j)+pext(i+1,j))
+     s               /cu(i,j)
+               enddo
+               um=um/ptot(j)
+            endif
+            do i=1,iim
+               ucov(i,j,l)=ucov(i,j,l)-cst(l)*(ucov(i,j,l)-um*cu(i,j))
+            enddo
+            ucov(iip1,j,l)=ucov(1,j,l)
+         enddo
+      enddo
+
+c  vent meridien
+      do l=l0,llm
+         do j=1,jjm
+            vm=0.
+            if(mode.ge.2) then
+               do i=1,iim
+                  vm=vm+vcov(i,j,l)*(pext(i,j)+pext(i,j+1))
+     s               /cv(i,j)
+               enddo
+               vm=vm/(ptot(j)+ptot(j+1))
+            endif
+            do i=1,iim
+               vcov(i,j,l)=vcov(i,j,l)-cst(l)*(vcov(i,j,l)-vm*cv(i,j))
+            enddo
+            vcov(iip1,j,l)=vcov(1,j,l)
+         enddo
+      enddo
+
+      RETURN
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/sponge.h	(revision 57)
@@ -0,0 +1,9 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'sponge.h'
+
+      COMMON/com_sponge/callsponge,mode_sponge,hsponge,tetasponge
+
+      LOGICAL   callsponge
+      INTEGER   mode_sponge
+      REAL   hsponge,tetasponge
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/start2archive.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/start2archive.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/start2archive.F	(revision 57)
@@ -0,0 +1,354 @@
+c=======================================================================
+      PROGRAM start2archive
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c
+c   Objet:   Passage des  fichiers netcdf d'etat initial "start" et
+c   -----    "startfi" a un fichier netcdf unique "start_archive" 
+c
+c  "start_archive" est une banque d'etats initiaux:
+c  On peut stocker plusieurs etats initiaux dans un meme fichier "start_archive"
+c    (Veiller dans ce cas avoir un day_ini different pour chacun des start)
+c 
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+
+#include "dimphys.h"
+#include "netcdf.inc"
+
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c variables dynamiques du GCM
+c -----------------------------
+      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants
+      REAL teta(ip1jmp1,llm)                    ! temperature potentielle 
+      REAL q(ip1jmp1,llm,nqmx)               ! champs advectes
+      REAL pks(ip1jmp1)                      ! exner (f pour filtre)
+      REAL pk(ip1jmp1,llm)
+      REAL pkf(ip1jmp1,llm)
+      REAL beta(iip1,jjp1,llm)
+      REAL phis(ip1jmp1)                     ! geopotentiel au sol
+      REAL masse(ip1jmp1,llm)                ! masse de l'atmosphere
+      REAL ps(ip1jmp1)                       ! pression au sol
+      REAL p3d(iip1, jjp1, llm+1)            ! pression aux interfaces
+      
+c Variable Physiques (grille physique)
+c ------------------------------------
+      REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx),co2ice(ngridmx)
+      REAL q2(ngridmx,nlayermx+1),qsurf(ngridmx,nqmx)
+      REAL emis(ngridmx)
+      INTEGER start,length
+      PARAMETER (length = 100)
+      REAL tab_cntrl_fi(length) ! tableau des parametres de startfi
+      INTEGER*4 day_ini_fi
+
+c Variable naturelle / grille scalaire
+c ------------------------------------
+      REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm)
+      REAL tsurfS(ip1jmp1),tsoilS(ip1jmp1,nsoilmx),co2iceS(ip1jmp1)
+      REAL q2S(ip1jmp1,llm+1),qsurfS(ip1jmp1,nqmx)
+      REAL emisS(ip1jmp1)
+
+c Variables intermediaires : vent naturel, mais pas coord scalaire
+c----------------------------------------------------------------
+      REAL vn(ip1jm,llm),un(ip1jmp1,llm)
+
+c Autres  variables
+c -----------------
+      LOGICAL startdrs
+      INTEGER Lmodif
+
+      REAL ptotal, co2icetotal
+      REAL timedyn,timefi !fraction du jour dans start, startfi
+      REAL date
+
+      CHARACTER*2 str2
+      CHARACTER*80 fichier 
+      data  fichier /'startfi'/
+
+      INTEGER ij, l,i,j,isoil,iq
+      character*80      fichnom
+      integer :: ierr,ntime
+
+c Netcdf
+c-------
+      integer varid,dimid,timelen 
+      INTEGER nid,nid1
+
+c-----------------------------------------------------------------------
+c   Initialisations 
+c-----------------------------------------------------------------------
+
+      grireg   = .TRUE.
+
+c=======================================================================
+c Lecture des donnees
+c=======================================================================
+
+      fichnom = 'start.nc'
+      CALL dynetat0(fichnom,nqmx,vcov,ucov,teta,q,masse,
+     .       ps,phis,timedyn)
+
+      fichnom = 'startfi.nc'
+      Lmodif=0
+
+      CALL phyetat0 (fichnom,0,Lmodif,nsoilmx,nqmx,day_ini_fi,timefi,
+     .      tsurf,tsoil,emis,q2,qsurf,co2ice)
+
+       ierr = NF_OPEN (fichnom, NF_NOWRITE,nid1)
+       IF (ierr.NE.NF_NOERR) THEN
+         write(6,*)' Pb d''ouverture du fichier'//fichnom
+        CALL ABORT
+       ENDIF
+                                                
+      ierr = NF_INQ_VARID (nid1, "controle", varid)
+      IF (ierr .NE. NF_NOERR) THEN
+       PRINT*, "start2archive: Le champ <controle> est absent"
+       CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+       ierr = NF_GET_VAR_DOUBLE(nid1, varid, tab_cntrl_fi)
+#else
+      ierr = NF_GET_VAR_REAL(nid1, varid, tab_cntrl_fi)
+#endif
+       IF (ierr .NE. NF_NOERR) THEN
+          PRINT*, "start2archive: Lecture echoue pour <controle>"
+          CALL abort
+       ENDIF
+                                
+      ierr = NF_CLOSE(nid1)
+
+c-----------------------------------------------------------------------
+c Controle de la synchro
+c-----------------------------------------------------------------------
+!mars a voir      if ((day_ini_fi.ne.day_ini).or.(abs(timefi-timedyn).gt.1.e-10)) 
+      if ((day_ini_fi.ne.day_ini)) 
+     &  stop ' Probleme de Synchro entre start et startfi !!!'
+
+
+c *****************************************************************
+c    Option : Reinitialisation des dates dans la premieres annees :
+       do while (day_ini.ge.669)
+          day_ini=day_ini-669
+       enddo
+c *****************************************************************
+
+c-----------------------------------------------------------------------
+c   Initialisations 
+c-----------------------------------------------------------------------
+
+      CALL defrun_new(99, .FALSE. )
+      call iniconst
+      call inigeom
+      call inifilr
+      CALL pression(ip1jmp1, ap, bp, ps, p3d)
+      call exner_hyb(ip1jmp1, ps, p3d, beta, pks, pk, pkf)
+
+c=======================================================================
+c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire
+c=======================================================================
+c  Les variables modeles dependent de la resolution. Il faut donc
+c  eliminer les facteurs responsables de cette dependance
+c  (pour utiliser newstart)
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c Vent   (depend de la resolution horizontale) 
+c-----------------------------------------------------------------------
+c
+c ucov --> un  et  vcov --> vn
+c un --> us  et   vn --> vs
+c
+c-----------------------------------------------------------------------
+
+      call covnat(llm,ucov, vcov, un, vn) 
+      call wind_scal(un,vn,us,vs) 
+
+c-----------------------------------------------------------------------
+c Temperature  (depend de la resolution verticale => de "sigma.def")
+c-----------------------------------------------------------------------
+c
+c h --> T
+c
+c-----------------------------------------------------------------------
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+            T(ij,l)=teta(ij,l)*pk(ij,l)/cpp !mars deduit de l'equation dans newstart
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c Variable physique 
+c-----------------------------------------------------------------------
+c
+c tsurf --> tsurfS
+c co2ice --> co2iceS
+c tsoil --> tsoilS
+c emis --> emisS
+c q2 --> q2S
+c qsurf --> qsurfS
+c
+c-----------------------------------------------------------------------
+
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf,tsurfS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,co2ice,co2iceS)
+      call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil,tsoilS)
+      call gr_fi_dyn(1,ngridmx,iip1,jjp1,emis,emisS)
+      call gr_fi_dyn(llm+1,ngridmx,iip1,jjp1,q2,q2S)
+      call gr_fi_dyn(nqmx,ngridmx,iip1,jjp1,qsurf,qsurfS)
+
+c=======================================================================
+c Info pour controler
+c=======================================================================
+
+      ptotal =  0.
+      co2icetotal = 0.
+      DO j=1,jjp1
+         DO i=1,iim
+           ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g
+           co2icetotal = co2icetotal + 
+     &            co2iceS(i+(iim+1)*(j-1))*aire(i+(iim+1)*(j-1))
+         ENDDO
+      ENDDO
+      write(*,*)'Ancienne grille : masse de l''atm :',ptotal
+      write(*,*)'Ancienne grille : masse de la glace CO2 :',co2icetotal
+
+c-----------------------------------------------------------------------
+c Passage de "ptotal" et "co2icetotal" par tab_cntrl_fi
+c-----------------------------------------------------------------------
+
+      tab_cntrl_fi(49) = ptotal
+      tab_cntrl_fi(50) = co2icetotal
+
+c=======================================================================
+c Ecriture dans le fichier  "start_archive"
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c Ouverture de "start_archive" 
+c-----------------------------------------------------------------------
+
+      ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid)
+ 
+c-----------------------------------------------------------------------
+c  si "start_archive" n'existe pas:
+c    1_ ouverture
+c    2_ creation de l'entete dynamique ("ini_archive")
+c-----------------------------------------------------------------------
+c ini_archive:
+c On met dans l'entete le tab_cntrl dynamique (1 a 16) 
+c  On y ajoute les valeurs du tab_cntrl_fi (a partir de 51)
+c  En plus les deux valeurs ptotal et co2icetotal (99 et 100)
+c-----------------------------------------------------------------------
+
+      if (ierr.ne.NF_NOERR) then
+         write(*,*)'OK, Could not open file "start_archive.nc"'
+         write(*,*)'So let s create a new "start_archive"'
+         ierr = NF_CREATE('start_archive.nc', NF_CLOBBER, nid)
+         call ini_archive(nid,day_ini,phis,tab_cntrl_fi)
+      endif
+
+c-----------------------------------------------------------------------
+c Ecriture de la coordonnee temps (date en jours)
+c-----------------------------------------------------------------------
+
+      date = day_ini
+      ierr= NF_INQ_VARID(nid,"Time",varid)
+      ierr= NF_INQ_DIMID(nid,"Time",dimid)
+      ierr= NF_INQ_DIMLEN(nid,dimid,timelen)
+      ntime=timelen+1
+
+      write(*,*) "******************"
+      write(*,*) "ntime",ntime
+      write(*,*) "******************"
+#ifdef NC_DOUBLE
+      ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+#else
+      ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write(*,*) "time matter ",NF_STRERROR(ierr)
+         stop
+      endif
+
+c-----------------------------------------------------------------------
+c Ecriture des champs  (co2ice,emis,ps,Tsurf,T,u,v,q2,q,qsurf)
+c-----------------------------------------------------------------------
+c ATTENTION: q2 a une couche de plus!!!!
+c    Pour creer un fichier netcdf lisible par grads,
+c    On passe donc une des couches de q2 a part
+c    comme une variable 2D (la couche au sol: "q2surf")
+c    Les lmm autres couches sont nommees "q2atm" (3D) 
+c-----------------------------------------------------------------------
+
+      call write_archive(nid,ntime,'co2ice','couche de glace co2',
+     &  'kg/m2',2,co2iceS)
+      call write_archive(nid,ntime,'emis','grd emis',' ',2,emisS)
+      call write_archive(nid,ntime,'ps','Psurf','Pa',2,ps)
+      call write_archive(nid,ntime,'tsurf','surf T','K',2,tsurfS)
+      call write_archive(nid,ntime,'temp','temperature','K',3,t)
+      call write_archive(nid,ntime,'u','Vent zonal','m.s-1',3,us)
+      call write_archive(nid,ntime,'v','Vent merid','m.s-1',3,vs)
+      call write_archive(nid,ntime,'q2surf','wind variance','m2.s-2',2,
+     .              q2S)
+      call write_archive(nid,ntime,'q2atm','wind variance','m2.s-2',3,
+     .              q2S(1,2))
+
+c-----------------------------------------------------------------------
+c Ecriture du champs  tsoil  ( Tg[1,10] )
+c-----------------------------------------------------------------------
+c "tsoil" Temperature au sol definie dans 10 couches dans le sol
+c   Les 10 couches sont lues comme 10 champs 
+c  nommees Tg[1,10]
+
+      do isoil=1,nsoilmx
+       write(str2,'(i2.2)') isoil
+       call write_archive(nid,ntime,'Tg'//str2,'Ground Temperature ',
+     .   'K',2,tsoilS(1,isoil))
+      enddo
+c-----------------------------------------------------------------------
+c Ecriture du champs  q  ( q[1,nqmx] )
+c-----------------------------------------------------------------------
+      do iq=1,nqmx
+       write(str2,'(i2.2)') iq
+        call write_archive(nid,ntime,'q'//str2,'tracer','kg/kg',
+     .         3,q(1,1,iq))
+      end do
+c-----------------------------------------------------------------------
+c Ecriture du champs  qsurf  ( qsurf[1,nqmx] )
+c-----------------------------------------------------------------------
+      do iq=1,nqmx
+       write(str2,'(i2.2)') iq
+       call write_archive(nid,ntime,'qsurf'//str2,'Tracer on surface',
+     $  'kg.m-2',2,qsurfS(1,iq))
+      enddo
+
+      ierr=NF_CLOSE(nid)
+
+c-----------------------------------------------------------------------
+c Fin 
+c-----------------------------------------------------------------------
+
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/temps.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/temps.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/temps.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/test_period.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/test_period.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/test_period.F	(revision 57)
@@ -0,0 +1,86 @@
+      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)
+          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, ij+iim = ', nq, l, ij, ij+iim
+        PRINT *,'q(ij,l,nq) q(ij+iim,l,nq) ',q(ij,l,nq),q(ij+iim,l,nq)
+          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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/testharm.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/testharm.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/testharm.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tourpot.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tourpot.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tourpot.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/traceur.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/traceur.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/traceur.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracstoke.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracstoke.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracstoke.h	(revision 57)
@@ -0,0 +1,2 @@
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracvl.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracvl.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/tracvl.F	(revision 57)
@@ -0,0 +1,127 @@
+      SUBROUTINE tracvl(numvanle,iapp_tracvl,nq,pbaru,pbarv ,
+     *                    p, masse , q, iapptrac, iadv1, teta, pk  )
+c
+c     Auteur :  F. Hourdin
+c
+c
+ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
+c                 F. Codron     (10/99)
+
+c
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comvert.h"
+#include "comgeom.h"
+
+c     .... Arguments  ....
+c
+      INTEGER numvanle, nq, iapp_tracvl, iapptrac, iadv1
+
+      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
+      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm)
+      REAL pk(ip1jmp1,llm)
+
+c     ....  var. locales  .....
+c
+      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
+      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
+
+      REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
+
+
+      INTEGER iadvtr, numvan
+      INTEGER ij,l,iq
+      REAL zdpmin, zdpmax
+      EXTERNAL  minmax
+      SAVE iadvtr, massem, pbaruc, pbarvc, numvan
+      DATA iadvtr/0/
+
+      numvan = numvanle
+
+      IF(iadvtr.EQ.0) THEN
+         CALL initial0(ijp1llm,pbaruc)
+         CALL initial0(ijmllm,pbarvc)
+      ENDIF
+
+c   accumulation des flux de masse horizontaux
+      DO l=1,llm
+         DO ij = 1,ip1jmp1
+            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
+         ENDDO
+         DO ij = 1,ip1jm
+            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
+         ENDDO
+      ENDDO
+
+c   selection de la masse instantannee des mailles avant le transport.
+      IF(iadvtr.EQ.0) THEN
+
+         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
+ccc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
+c
+      ENDIF
+
+      iadvtr   = iadvtr+1
+      iapptrac = iadvtr
+
+
+c   Test pour savoir si on advecte a ce pas de temps
+      IF ( iadvtr.EQ.iapp_tracvl ) THEN
+
+cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
+cc
+
+c   traitement des flux de masse avant advection.
+c     1. calcul de w
+c     2. groupement des mailles pres du pole.
+
+        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
+
+
+c  test sur l'eventuelle creation de valeurs negatives de la masse
+         DO l=1,llm-1
+            DO ij = iip2+1,ip1jm
+              zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l)
+     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
+     s                  + wg(ij,l+1) - wg(ij,l)
+            ENDDO
+            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
+            DO ij = iip2,ip1jm
+               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) 
+            ENDDO 
+
+
+            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
+
+            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
+            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
+     s        '   MAX:', zdpmax
+            ENDIF
+
+         ENDDO
+
+c   Advection proprement dite.
+c
+c   test sur iadv1 pour le schema de vapeur d'eau
+c
+         IF (numvanle.EQ.1.AND.iadv1.EQ.4) THEN
+           CALL vlspltqs( q(1,1,1), 2., massem, wg ,
+     *                 pbarug,pbarvg,dtvr,p,pk,teta )
+           numvan = 2
+         ENDIF
+
+         DO iq = numvan, nq
+          CALL vlsplt( q(1,1,iq), 2. ,massem,wg,pbarug,pbarvg,dtvr )
+         ENDDO
+         iadvtr=0
+
+c   on reinitialise a zero les flux de masse cumules.
+
+      ENDIF ! if iadvtr.EQ.iapp_tracvl
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vanleer.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vanleer.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vanleer.F	(revision 57)
@@ -0,0 +1,71 @@
+      SUBROUTINE vanleer(numvanle,iapp_tracvl,nq,q,pbaru,pbarv ,
+     *                     p ,masse, dq ,  iadv1, teta, pk      )
+c
+      IMPLICIT NONE
+c
+c     Auteurs:   F.Hourdin , P.Le Van, F.Forget, F.Codron  
+c
+c=======================================================================
+c
+c       Shema de  Van Leer
+c       Version simplifiée pour Mars
+c       (L'original bugue a cause des histoires d'eau terrestre !!)
+c       FF 2003
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+
+c   Arguments:
+c   ----------
+      INTEGER nq, numvanle, iapp_tracvl, iadv1 
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm)
+      REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nq),dq( ip1jmp1,llm,nq )
+      REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm)
+c  ..................................................................
+c
+c   Local:
+c   ------
+
+      EXTERNAL  tracvl,minmaxq, qminimum
+      INTEGER ij,l, iq, iapptrac
+      REAL finmasse(ip1jmp1,llm), dtvrtrac
+cc
+
+        CALL SCOPY( nq * ijp1llm, q, 1, dq, 1 )
+
+c   advection
+
+      CALL tracvl( numvanle,iapp_tracvl,nq,pbaru,pbarv,p , masse,q  ,
+     *                      iapptrac, iadv1, teta ,pk              )
+
+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 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 ******
+
+          dtvrtrac = iapp_tracvl * dtvr
+c
+           DO iq = 1 , nq ! modif special mars : 2 devient nq
+            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
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vitvert.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vitvert.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vitvert.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlsplt.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlsplt.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlsplt.F	(revision 57)
@@ -0,0 +1,887 @@
+      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     SPECIAL MARS :  on ajoute un test ("max") pour eviter les division
+c     par des "dyq" trop faible (special compilateur SUN) 27/11/2003 F. Forget
+
+      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)/ max(abs(dyq(ij,l)),1.E-30),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs= min(pente_max*adyqv(ij+ip1jm-iip1) 
+     &              / max(abs(dyq(ij+ip1jm,l)),1.E-30) ,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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlspltqs.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlspltqs.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/vlspltqs.F	(revision 57)
@@ -0,0 +1,775 @@
+       SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt,
+     ,                                  p,pk,teta                 )
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron 
+c
+c    ********************************************************************
+c          Shema  d'advection " pseudo amont " .
+c      + test sur humidite specifique: Q advecte< Qsat aval
+c                   (F. Codron, 10/99)
+c    ********************************************************************
+c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+c
+c     pente_max facteur de limitation des pentes: 2 en general
+c                                                0 pour un schema amont
+c     pbaru,pbarv,w flux de masse en u ,v ,w
+c     pdt pas de temps
+c
+c     teta temperature potentielle, p pression aux interfaces,
+c     pk exner au milieu des couches necessaire pour calculer Qsat
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL w(ip1jmp1,llm),pdt
+      REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+      REAL qsat(ip1jmp1,llm)
+      REAL zm(ip1jmp1,llm)
+      REAL mu(ip1jmp1,llm)
+      REAL mv(ip1jm,llm)
+      REAL mw(ip1jmp1,llm+1)
+      REAL zq(ip1jmp1,llm)
+      REAL temps1,temps2,temps3
+      REAL zzpbar, zzw
+      LOGICAL testcpu
+      SAVE testcpu
+      SAVE temps1,temps2,temps3
+
+      REAL qmin,qmax
+      DATA qmin,qmax/0.,1.e33/
+      DATA testcpu/.false./
+      DATA temps1,temps2,temps3/0.,0.,0./
+
+c--pour rapport de melange saturant--
+
+      REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
+      REAL ptarg,pdelarg,foeew,zdelta
+      REAL tempe(ip1jmp1)
+
+c    fonction psat(T)
+
+       FOEEW ( PTARG,PDELARG ) = EXP (
+     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
+     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+
+        r2es  = 380.11733 
+        r3les = 17.269
+        r3ies = 21.875
+        r4les = 35.86
+        r4ies = 7.66
+        retv = 0.6077667
+        rtt  = 273.16
+
+c-- Calcul de Qsat en chaque point
+c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
+c   pour eviter une exponentielle.
+        DO l = 1, llm
+         DO ij = 1, ip1jmp1
+          tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
+         ENDDO
+         DO ij = 1, ip1jmp1
+          zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
+          play   = 0.5*(p(ij,l)+p(ij,l+1))
+          qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
+          qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
+         ENDDO
+        ENDDO
+
+
+c      PRINT*,'Debut vlsplt version debug sans vlyqs'
+
+        zzpbar = 0.5 * pdt
+        zzw    = pdt
+      DO l=1,llm
+        DO ij = iip2,ip1jm
+            mu(ij,l)=pbaru(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jm
+            mv(ij,l)=pbarv(ij,l) * zzpbar
+         ENDDO
+         DO ij=1,ip1jmp1
+            mw(ij,l)=w(ij,l) * zzw
+         ENDDO
+      ENDDO
+
+      DO ij=1,ip1jmp1
+         mw(ij,llm+1)=0.
+      ENDDO
+
+      CALL SCOPY(ijp1llm,q,1,zq,1)
+      CALL SCOPY(ijp1llm,masse,1,zm,1)
+
+c      call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
+      call vlxqs(zq,pente_max,zm,mu,qsat)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
+
+      call vlyqs(zq,pente_max,zm,mv,qsat)
+
+
+c      call minmaxq(zq,qmin,qmax,'avant vlz     ')
+
+      call vlz(zq,pente_max,zm,mw)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlyqs     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vlyqs     ')
+
+      call vlyqs(zq,pente_max,zm,mv,qsat)
+
+
+c     call minmaxq(zq,qmin,qmax,'avant vlxqs     ')
+c     call minmaxq(zm,qmin,qmax,'M avant vlxqs     ')
+
+      call vlxqs(zq,pente_max,zm,mu,qsat)
+
+c     call minmaxq(zq,qmin,qmax,'apres vlxqs     ')
+c     call minmaxq(zm,qmin,qmax,'M apres vlxqs     ')
+
+
+      DO l=1,llm
+         DO ij=1,ip1jmp1
+           q(ij,l)=zq(ij,l)
+         ENDDO
+         DO ij=1,ip1jm+1,iip1
+            q(ij+iim,l)=q(ij,l)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
+      SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL u_m( ip1jmp1,llm )
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+      INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm)
+c
+      REAL new_m,zu_m,zdum(ip1jmp1,llm)
+      REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1)
+      REAL zz(ip1jmp1)
+      REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm)
+      REAL u_mq(ip1jmp1,llm)
+
+      Logical first,testcpu
+      SAVE first,testcpu
+
+      REAL      SSUM
+      EXTERNAL  SSUM
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+
+
+      DATA first,testcpu/.true.,.false./
+
+      IF(first) THEN
+         temps1=0.
+         temps2=0.
+         temps3=0.
+         temps4=0.
+         temps5=0.
+         first=.false.
+      ENDIF
+
+c   calcul de la pente a droite et a gauche de la maille
+
+
+      IF (pente_max.gt.-1.e-5) THEN
+c     IF (pente_max.gt.10) THEN
+
+c   calcul des pentes avec limitation, Van Leer scheme I:
+c   -----------------------------------------------------
+
+c   calcul de la pente aux points u
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+c              IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0'
+c              sigu(ij)=u_m(ij,l)/masse(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+c              sigu(ij)=sigu(ij-iim)
+            ENDDO
+
+            DO ij=iip2,ip1jm
+               adxqu(ij)=abs(dxqu(ij))
+            ENDDO
+
+c   calcul de la pente maximum dans la maille en valeur absolue
+
+            DO ij=iip2+1,ip1jm
+               dxqmax(ij,l)=pente_max*
+     ,      min(adxqu(ij-1),adxqu(ij))
+c limitation subtile
+c    ,      min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij)))
+          
+
+            ENDDO
+
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqmax(ij-iim,l)=dxqmax(ij,l)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+#ifdef CRAY
+               dxq(ij,l)=
+     ,         cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij))
+#else
+               IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN
+                  dxq(ij,l)=dxqu(ij-1)+dxqu(ij)
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+#endif
+               dxq(ij,l)=0.5*dxq(ij,l)
+               dxq(ij,l)=
+     ,         sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l))
+            ENDDO
+
+         ENDDO ! l=1,llm
+
+      ELSE ! (pente_max.lt.-1.e-5)
+
+c   Pentes produits:
+c   ----------------
+
+         DO l = 1, llm
+            DO ij=iip2,ip1jm-1
+               dxqu(ij)=q(ij+1,l)-q(ij,l)
+            ENDDO
+            DO ij=iip1+iip1,ip1jm,iip1
+               dxqu(ij)=dxqu(ij-iim)
+            ENDDO
+
+            DO ij=iip2+1,ip1jm
+               zz(ij)=dxqu(ij-1)*dxqu(ij)
+               zz(ij)=zz(ij)+zz(ij)
+               IF(zz(ij).gt.0) THEN
+                  dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij))
+               ELSE
+c   extremum local
+                  dxq(ij,l)=0.
+               ENDIF
+            ENDDO
+
+         ENDDO
+
+      ENDIF ! (pente_max.lt.-1.e-5)
+
+c   bouclage de la pente en iip1:
+c   -----------------------------
+
+      DO l=1,llm
+         DO ij=iip1+iip1,ip1jm,iip1
+            dxq(ij-iim,l)=dxq(ij,l)
+         ENDDO
+
+         DO ij=1,ip1jmp1
+            iadvplus(ij,l)=0
+         ENDDO
+
+      ENDDO
+
+
+c   calcul des flux a gauche et a droite
+
+#ifdef CRAY
+c--pas encore modification sur Qsat
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l),
+     ,                     1.+u_m(ij,l)/masse(ij+1,l),
+     ,                     u_m(ij,l))
+          zdum(ij,l)=0.5*zdum(ij,l)
+          u_mq(ij,l)=cvmgp(
+     ,                q(ij,l)+zdum(ij,l)*dxq(ij,l),
+     ,                q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l),
+     ,                u_m(ij,l))
+          u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l)
+       ENDDO
+      ENDDO
+#else
+c   on cumule le flux correspondant a toutes les mailles dont la masse
+c   au travers de la paroi pENDant le pas de temps.
+c   le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind)
+      DO l=1,llm
+       DO ij=iip2,ip1jm-1
+          IF (u_m(ij,l).gt.0.) THEN
+             zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l))
+          ELSE
+             zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l)
+             u_mq(ij,l)=u_m(ij,l)*
+     $         min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l))
+          ENDIF
+       ENDDO
+      ENDDO
+#endif
+
+
+c   detection des points ou on advecte plus que la masse de la
+c   maille
+      DO l=1,llm
+         DO ij=iip2,ip1jm-1
+            IF(zdum(ij,l).lt.0) THEN
+               iadvplus(ij,l)=1
+               u_mq(ij,l)=0.
+            ENDIF
+         ENDDO
+      ENDDO
+      DO l=1,llm
+       DO ij=iip1+iip1,ip1jm,iip1
+          iadvplus(ij,l)=iadvplus(ij-iim,l)
+       ENDDO
+      ENDDO
+
+
+
+c   traitement special pour le cas ou on advecte en longitude plus que le
+c   contenu de la maille.
+c   cette partie est mal vectorisee.
+
+c   pas d'influence de la pression saturante (pour l'instant)
+
+c  calcul du nombre de maille sur lequel on advecte plus que la maille.
+
+      n0=0
+      DO l=1,llm
+         nl(l)=0
+         DO ij=iip2,ip1jm
+            nl(l)=nl(l)+iadvplus(ij,l)
+         ENDDO
+         n0=n0+nl(l)
+      ENDDO
+
+      IF(n0.gt.1) THEN
+ccc      PRINT*,'Nombre de points pour lesquels on advect plus que le'
+ccc     &       ,'contenu de la maille : ',n0
+
+         DO l=1,llm
+            IF(nl(l).gt.0) THEN
+               iju=0
+c   indicage des mailles concernees par le traitement special
+               DO ij=iip2,ip1jm
+                  IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN
+                     iju=iju+1
+                     indu(iju)=ij
+                  ENDIF
+               ENDDO
+               niju=iju
+c              PRINT*,'niju,nl',niju,nl(l)
+
+c  traitement des mailles
+               DO iju=1,niju
+                  ij=indu(iju)
+                  j=(ij-1)/iip1+1
+                  zu_m=u_m(ij,l)
+                  u_mq(ij,l)=0.
+                  IF(zu_m.gt.0.) THEN
+                     ijq=ij
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m-masse(ijq,l)
+                        i=mod(i-2+iim,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*
+     &               (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ELSE
+                     ijq=ij+1
+                     i=ijq-(j-1)*iip1
+c   accumulation pour les mailles completements advectees
+                     do while(-zu_m.gt.masse(ijq,l))
+                        u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l)
+                        zu_m=zu_m+masse(ijq,l)
+                        i=mod(i,iim)+1
+                        ijq=(j-1)*iip1+i
+                     ENDDO
+c   ajout de la maille non completement advectee
+                     u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)-
+     &               0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l))
+                  ENDIF
+               ENDDO
+            ENDIF
+         ENDDO
+      ENDIF  ! n0.gt.0 
+
+
+
+c   bouclage en latitude
+
+      DO l=1,llm
+        DO ij=iip1+iip1,ip1jm,iip1
+           u_mq(ij,l)=u_mq(ij-iim,l)
+        ENDDO
+      ENDDO
+
+
+c   calcul des tendances
+
+      DO l=1,llm
+         DO ij=iip2+1,ip1jm
+            new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+
+     &      u_mq(ij-1,l)-u_mq(ij,l))
+     &      /new_m
+            masse(ij,l)=new_m
+         ENDDO
+c   Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous)
+         DO ij=iip1+iip1,ip1jm,iip1
+            q(ij-iim,l)=q(ij,l)
+            masse(ij-iim,l)=masse(ij,l)
+         ENDDO
+      ENDDO
+
+c     CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1)
+c     CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1)
+
+
+      RETURN
+      END
+      SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " .
+c    ********************************************************************
+c     q,masse_adv_v,w sont des arguments d'entree  pour le s-pg ....
+c     qsat 	       est   un argument de sortie pour le s-pg ....
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "comgeom.h"
+c
+c
+c   Arguments:
+c   ----------
+      REAL masse(ip1jmp1,llm),pente_max
+      REAL masse_adv_v( ip1jm,llm)
+      REAL q(ip1jmp1,llm)
+      REAL qsat(ip1jmp1,llm)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l
+c
+      REAL airej2,airejjm,airescb(iim),airesch(iim)
+      REAL dyq(ip1jmp1,llm),dyqv(ip1jm)
+      REAL adyqv(ip1jm),dyqmax(ip1jmp1)
+      REAL qbyv(ip1jm,llm)
+
+      REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs
+c     REAL newq,oldmasse
+      Logical first,testcpu
+      REAL temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE temps0,temps1,temps2,temps3,temps4,temps5
+      SAVE first,testcpu
+
+      REAL convpn,convps,convmpn,convmps
+      REAL sinlon(iip1),sinlondlon(iip1)
+      REAL coslon(iip1),coslondlon(iip1)
+      SAVE sinlon,coslon,sinlondlon,coslondlon
+      SAVE airej2,airejjm
+c
+c
+      REAL      SSUM
+      EXTERNAL  SSUM
+
+      DATA first,testcpu/.true.,.false./
+      DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./
+
+      IF(first) THEN
+         PRINT*,'Shema  Amont nouveau  appele dans  Vanleer   '
+         first=.false.
+         do i=2,iip1
+            coslon(i)=cos(rlonv(i))
+            sinlon(i)=sin(rlonv(i))
+            coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi
+            sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi
+         ENDDO
+         coslon(1)=coslon(iip1)
+         coslondlon(1)=coslondlon(iip1)
+         sinlon(1)=sinlon(iip1)
+         sinlondlon(1)=sinlondlon(iip1)
+         airej2 = SSUM( iim, aire(iip2), 1 )
+         airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) 
+      ENDIF
+
+c
+
+
+      DO l = 1, llm
+c
+c   --------------------------------
+c      CALCUL EN LATITUDE
+c   --------------------------------
+
+c   On commence par calculer la valeur du traceur moyenne sur le premier cercle
+c   de latitude autour du pole (qpns pour le pole nord et qpsn pour
+c    le pole nord) qui sera utilisee pour evaluer les pentes au pole.
+
+      DO i = 1, iim
+      airescb(i) = aire(i+ iip1) * q(i+ iip1,l)
+      airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l)
+      ENDDO
+      qpns   = SSUM( iim,  airescb ,1 ) / airej2
+      qpsn   = SSUM( iim,  airesch ,1 ) / airejjm
+
+c   calcul des pentes aux points v
+
+      DO ij=1,ip1jm
+         dyqv(ij)=q(ij,l)-q(ij+iip1,l)
+         adyqv(ij)=abs(dyqv(ij))
+      ENDDO
+
+c   calcul des pentes aux points scalaires
+
+      DO ij=iip2,ip1jm
+         dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij))
+         dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij))
+         dyqmax(ij)=pente_max*dyqmax(ij)
+      ENDDO
+
+c   calcul des pentes aux poles
+
+      DO ij=1,iip1
+         dyq(ij,l)=qpns-q(ij+iip1,l)
+         dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn
+      ENDDO
+
+c   filtrage de la derivee
+      dyn1=0.
+      dys1=0.
+      dyn2=0.
+      dys2=0.
+      DO ij=1,iim
+         dyn1=dyn1+sinlondlon(ij)*dyq(ij,l)
+         dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l)
+         dyn2=dyn2+coslondlon(ij)*dyq(ij,l)
+         dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l)
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij)
+         dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij)
+      ENDDO
+
+c   calcul des pentes limites aux poles
+
+      fn=1.
+      fs=1.
+      DO ij=1,iim
+         IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN
+            fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn)
+         ENDIF
+      IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN
+         fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs)
+         ENDIF
+      ENDDO
+      DO ij=1,iip1
+         dyq(ij,l)=fn*dyq(ij,l)
+         dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l)
+      ENDDO
+
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C  En memoire de dIFferents tests sur la 
+C  limitation des pentes aux poles.
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C     PRINT*,dyq(1)
+C     PRINT*,dyqv(iip1+1)
+C     apn=abs(dyq(1)/dyqv(iip1+1))
+C     PRINT*,dyq(ip1jm+1)
+C     PRINT*,dyqv(ip1jm-iip1+1)
+C     aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1))
+C     DO ij=2,iim
+C        apn=amax1(abs(dyq(ij)/dyqv(ij)),apn)
+C        aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps)
+C     ENDDO
+C     apn=min(pente_max/apn,1.)
+C     aps=min(pente_max/aps,1.)
+C
+C
+C   cas ou on a un extremum au pole
+C
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   apn=0.
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    &   dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &   aps=0.
+C
+C   limitation des pentes aux poles
+C     DO ij=1,iip1
+C        dyq(ij)=apn*dyq(ij)
+C        dyq(ip1jm+ij)=aps*dyq(ip1jm+ij)
+C     ENDDO
+C
+C   test
+C      DO ij=1,iip1
+C         dyq(iip1+ij)=0.
+C         dyq(ip1jm+ij-iip1)=0.
+C      ENDDO
+C      DO ij=1,ip1jmp1
+C         dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1))
+C      ENDDO
+C
+C changement 10 07 96
+C     IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.)
+C    &   THEN
+C        DO ij=1,iip1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=1,iip1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij))
+C        ENDDO
+C     ENDIF
+C
+C     IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)*
+C    & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.)
+C    &THEN
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=0.
+C        ENDDO
+C     ELSE
+C        DO ij=ip1jm+1,ip1jmp1
+C           dyqmax(ij)=pente_max*abs(dyqv(ij-iip1))
+C        ENDDO
+C     ENDIF
+C   fin changement 10 07 96
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+c   calcul des pentes limitees
+
+      DO ij=iip2,ip1jm
+         IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN
+            dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l))
+         ELSE
+            dyq(ij,l)=0.
+         ENDIF
+      ENDDO
+
+      ENDDO
+
+      DO l=1,llm
+       DO ij=1,ip1jm
+         IF( masse_adv_v(ij,l).GT.0. ) THEN
+           qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l )  +
+     ,      dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)))
+         ELSE
+              qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) *
+     ,                   0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) )
+         ENDIF
+          qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l)
+       ENDDO
+      ENDDO
+
+
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+            newmasse=masse(ij,l)
+     &      +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l))
+     &         /newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. ancienne version
+         convpn=SSUM(iim,qbyv(1,l),1)/apoln
+         convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln
+         DO ij = 1,iip1
+            newmasse=masse(ij,l)+convmpn*aire(ij)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/
+     &               newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+         convps  = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols
+         convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols
+         DO ij = ip1jm+1,ip1jmp1
+            newmasse=masse(ij,l)+convmps*aire(ij)
+            q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/
+     &               newmasse
+            masse(ij,l)=newmasse
+         ENDDO
+c.-. fin ancienne version
+
+c._. nouvelle version
+c        convpn=SSUM(iim,qbyv(1,l),1)
+c        convmpn=ssum(iim,masse_adv_v(1,l),1)
+c        oldmasse=ssum(iim,masse(1,l),1)
+c        newmasse=oldmasse+convmpn
+c        newq=(q(1,l)*oldmasse+convpn)/newmasse
+c        newmasse=newmasse/apoln
+c        DO ij = 1,iip1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c        convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)
+c        convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)
+c        oldmasse=ssum(iim,masse(ip1jm-iim,l),1)
+c        newmasse=oldmasse+convmps
+c        newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse
+c        newmasse=newmasse/apols
+c        DO ij = ip1jm+1,ip1jmp1
+c           q(ij,l)=newq
+c           masse(ij,l)=newmasse*aire(ij)
+c        ENDDO
+c._. fin nouvelle version
+      ENDDO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wind_scal.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wind_scal.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wind_scal.F	(revision 57)
@@ -0,0 +1,55 @@
+      SUBROUTINE wind_scal(pbaru,pbarv,us,vs)
+c=======================================================================
+c
+c
+c   Subject:
+c   ------
+c   On ramene les flux de masse /vents  aux points scalaires.
+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)
+      REAL us(ip1jmp1,llm), vs (ip1jmp1,llm)
+
+c   Local:
+c   ------
+
+      INTEGER ij,l
+
+c-----------------------------------------------------------------------
+
+c   transport zonal:
+c   ----------------
+      DO l=1,llm
+	 DO ij=2,ip1jmp1
+            us(ij,l)=.5*(pbaru(ij,l)+pbaru(ij-1,l))
+	 ENDDO
+      ENDDO
+      CALL SCOPY(jjp1*llm,us(iip1,1),iip1,us(1,1),iip1)
+
+
+c   Transport meridien:
+c   -------------------
+      DO l=1,llm
+         DO ij=iip2,ip1jm
+	    vs(ij,l)=.5*(pbarv(ij,l)+pbarv(ij-iip1,l))
+	 ENDDO
+	 DO ij=1,iip1
+	    vs(ij,l)=0.
+	    vs(ip1jm+ij,l)=0.
+	 ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wrgrads.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wrgrads.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/wrgrads.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/write_archive.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/write_archive.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/write_archive.F	(revision 57)
@@ -0,0 +1,202 @@
+c=======================================================================
+      subroutine write_archive(nid,ntime,nom,titre,unite,dim,px)
+c=======================================================================
+c
+c
+c   Date:    01/1997
+c   ----
+c
+c   Objet:   Ecriture de champs sur grille scalaire (iip1*jjp1)
+c   -----    dans un fichier DRS nomme "start_archive"
+c
+c    Il faut au prealable avoir cree un entete avec un "call ini_archive".
+c    Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature
+c    de surface), ou 0d (pour un scalaire qui ne depend que du temps)
+c    (ex: la longitude solaire)
+c
+c
+c   Arguments: 
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c		  nid      Unite logique du fichier "start_archive"
+c         nom      nom du champ a ecrire dans le fichier "start_archive"
+c         titre    titre de la variable dans le fichier DRS "start_archive"
+c         unite    unite de la variable ....
+c         dim      dimension de la variable a ecrire
+c         px       tableau contenant la variable a ecrire
+c
+c
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "control.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "description.h"
+#include "temps.h"
+#include "netcdf.inc"
+
+c-----------------------------------------------------------------------
+c	Declarations   
+c-----------------------------------------------------------------------
+
+c Arguments:
+
+      INTEGER nid,ntime,dim 
+      REAL px(iip1,jjp1,llm) 
+
+      CHARACTER*(*) nom, titre, unite
+
+      integer ierr
+
+
+c local
+      integer, dimension(4) :: edges,corner,id
+      integer :: varid,i,j,l
+c-----------------------------------------------------------------------
+c      Ecriture du champs dans le fichier            (3 cas)      
+c-----------------------------------------------------------------------
+
+!Cas Variable 3D
+!---------------
+        if (dim.eq.3) then
+
+!         Ecriture du champs
+
+! nom de la variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif
+
+! mars s'arranger pour qu'il n'y ai plus besoin de ca
+
+c          do l=1,llm
+c             do j=1,jjp1
+c                do i=1,iip1
+c                   pxbis(i,j,l)=px(i,j,llm-l+1)
+c                enddo
+c             enddo
+c          enddo
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=llm
+           edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom," ",nf_STRERROR(ierr)
+              call abort
+           endif
+
+!Cas Variable 2D
+!---------------
+
+        else if (dim.eq.2) then
+
+!         Ecriture du champs
+
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"Time",id(3))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+
+              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=ntime
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=1
+
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
+#else         
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif     
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
+              call abort
+           endif
+
+
+!Cas Variable 0D (scalaire dependant du temps)
+!---------------------------------------------
+
+        else if (dim.eq.0) then
+
+!         Ecriture du champs
+
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+!  choix du nom des coordonnees
+              ierr= NF_INQ_DIMID(nid,"temps",id(1))
+
+! Creation de la variable si elle n'existait pas
+
+              write (*,*) "====================="
+              write (*,*) "creation de ",nom
+
+              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
+
+           endif
+
+           corner(1)=ntime
+           edges(1)=1
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
+#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in write_archive"
+              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
+              call abort
+           endif
+
+        endif
+
+      return
+      end
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/xvik.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/xvik.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/dyn3d/xvik.F	(revision 57)
@@ -0,0 +1,514 @@
+      PROGRAM xvik
+      IMPLICIT NONE
+c=======================================================================
+c
+c  Pression au site Viking
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comconst.h"
+#include "comdissip.h"
+#include "comvert.h"
+#include "comgeom2.h"
+#include "logic.h"
+#include "temps.h"
+#include "control.h"
+#include "ener.h"
+#include "description.h"
+#include "netcdf.inc"      
+
+
+      INTEGER itau,nbpas,nbpasmx
+      PARAMETER(nbpasmx=1000000)
+      REAL temps(nbpasmx)
+      INTEGER unitlec
+      INTEGER i,j,l,jj
+      REAL constR
+
+c   Declarations NCDF:
+c   -----------------
+      CHARACTER*100  varname
+      INTEGER ierr,nid,nvarid,dimid
+      LOGICAL nc
+      INTEGER start_ps(3),start_temp(4),start_co2ice(3)
+      INTEGER count_ps(3),count_temp(4),count_co2ice(3)
+
+c   declarations pour les points viking:
+c   ------------------------------------
+      INTEGER ivik(2),jvik(2),ifile(2),iv
+      REAL lonvik(2),latvik(2),phivik(2),phisim(2)
+      REAL unanj
+
+c   variables meteo:
+c   ----------------
+      REAL vnat(iip1,jjm,llm),unat(iip1,jjp1,llm)
+      REAL t(iip1,jjp1,llm),ps(iip1,jjp1),pstot, phis(iip1,jjp1)
+      REAL co2ice(iip1,jjp1), captotN,captotS
+
+      REAL zp1,zp2,zp2_sm,zu,zv,zw(0:1,0:1,2),zalpha,zbeta
+
+      LOGICAL firstcal,lcal,latcal,lvent,day_ls
+      INTEGER*4 day0
+
+      REAL ziceco2(iip1,jjp1)
+      REAL day,zt,sollong,sol,dayw
+      REAL airtot1,gh
+
+      INTEGER ii,iyear,kyear
+
+      CHARACTER*1 chr2
+
+       
+c   declarations de l'interface avec mywrite:
+c   -----------------------------------------
+
+      CHARACTER file*80
+      CHARACTER pathchmp*80,pathsor*80,nomfich*80
+
+c   externe:
+c   --------
+
+      EXTERNAL iniconst,inigeom,covcont,mywrite
+      EXTERNAL inifilr,exner,pbar
+      EXTERNAL solarlong,coordij,moy2
+      EXTERNAL SSUM
+      REAL SSUM
+      EXTERNAL lnblnk
+      INTEGER lnblnk
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+c-----------------------------------------------------------------------
+c   initialisations:
+c   ----------------
+
+      unanj=667.9
+      print*,'WARNING!!!',unanj,'Jours/an'
+      nc=.true.
+      lcal=.true.
+      latcal=.true.
+      lvent=.false.
+      day_ls=.true.
+
+c lecture du fichier xvik.def
+
+      phivik(1)=-3627
+      phivik(2)=-4505
+
+
+
+      OPEN(99,file='xvik.def',form='formatted')
+
+      READ(99,*) 
+      READ(99,*,iostat=ierr) phivik
+      IF(ierr.NE.0) GOTO 105
+
+      READ(99,*,END=105)
+      READ(99,'(a)',END=105) pathchmp
+      READ(99,*,END=105)
+      READ(99,'(a)',END=105) pathsor
+      READ(99,*,END=105)
+c     READ(99,'(l1)',END=105) day_ls
+      READ(99,'(l1)',END=105)
+      READ(99,'(l1)',END=105) lcal
+      READ(99,'(l1)',END=105)
+      READ(99,'(l1)',END=105) lvent
+      READ(99,'(l1)',END=105)
+      READ(99,'(l1)',END=105) latcal
+ 
+ 105  CONTINUE
+      CLOSE(99)
+      write (*,*)'>>>>>>>>>>>>>>>>', phivik,g
+      DO iv=1,2
+         phivik(iv)=phivik(iv)*3.73
+      END DO
+
+
+c-----------------------------------------------------------------------
+c-----------------------------------------------------------------------
+c   ouverture des fichiers xgraph:
+c   ------------------------------
+
+      ifile(1)=12
+      ifile(2)=13
+      kyear=-1
+c      OPEN(77,file='xlongday',form='formatted')
+
+      unitlec=11
+c
+      PRINT*,'entrer le nom du fichier NC'
+      READ(5,'(a)') nomfich
+
+      PRINT *,'nomfich : ',nomfich
+
+
+c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+c   grande boucle sur les fichiers histoire:
+c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+      firstcal=.true.
+      DO WHILE(lnblnk(nomfich).GT.0.AND.lnblnk(nomfich).LT.50)
+      PRINT *,'nomfich : ',nomfich
+
+c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+      file=pathchmp(1:lnblnk(pathchmp))//'/'//
+     s     nomfich(1:lnblnk(nomfich))
+      PRINT*,'file.nc: ', file(1:lnblnk(file))//'.nc'
+      PRINT*,'timestep ',dtvr
+
+      IF(nc) THEN
+      ierr= NF_OPEN(file(1:lnblnk(file))//'.nc',NF_NOWRITE,nid)        
+      ELSE
+         PRINT*,'Ouverture binaire ',file
+         OPEN(unitlec,file=file,status='old',form='unformatted',
+     .   iostat=ierr)
+      ENDIF
+
+c----------------------------------------------------------------------
+c   initialisation de la physique:
+c   ------------------------------
+
+      CALL readhead_NC(file(1:lnblnk(file))//'.nc',day0,phis,constR)
+
+      WRITE (*,*) 'day0 = ' , day0
+
+      CALL iniconst
+      CALL inigeom
+      CALL inifilr
+
+
+c   Lecture temps :
+
+      ierr= NF_INQ_DIMID (nid,"Time",dimid)
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'xvik: Le champ <Time> est absent'
+          CALL abort
+        ENDIF
+
+      ierr= NF_INQ_DIMLEN (nid,dimid,nbpas)
+
+      ierr = NF_INQ_VARID (nid, "Time", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, temps)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, temps)
+#endif
+        IF (ierr.NE.NF_NOERR) THEN
+          PRINT*, 'xvik: Lecture echouee pour <Time>'
+          CALL abort
+        ENDIF
+
+        PRINT*,'temps',(temps(itau),itau=1,10)
+              
+c-----------------------------------------------------------------------
+c   coordonnees des point Viking:
+c   -----------------------------
+
+      latvik(1)=22.27*pi/180.
+      lonvik(1)=-47.9*pi/180.
+      latvik(2)=47.67*pi/180.
+      lonvik(2)=(360.-225.71)*pi/180.
+
+c   ponderations pour les 4 points autour de Viking
+      DO iv=1,2
+         CALL coordij(lonvik(iv),latvik(iv),ivik(iv),jvik(iv))
+         IF(lonvik(iv).lt.rlonv(ivik(iv))) THEN
+            ivik(iv)=ivik(iv)-1
+         ENDIF
+         IF(latvik(iv).gt.rlatu(jvik(iv))) THEN
+            jvik(iv)=jvik(iv)-1
+         ENDIF
+         zalpha=(lonvik(iv)-rlonv(ivik(iv)))/
+     s          (rlonv(ivik(iv)+1)-rlonv(ivik(iv)))
+         zbeta=(latvik(iv)-rlatu(jvik(iv)))/
+     s          (rlatu(jvik(iv)+1)-rlatu(jvik(iv)))
+         zw(0,0,iv)=(1.-zalpha)*(1.-zbeta)
+         zw(1,0,iv)=zalpha*(1.-zbeta)
+         zw(0,1,iv)=(1.-zalpha)*zbeta
+         zw(1,1,iv)=zalpha*zbeta
+      ENDDO
+
+c   altitude reelle et modele aux points Viking
+      DO iv=1,2
+         phisim(iv)=0.
+         DO jj=0,1
+            j=jvik(iv)+jj
+            DO ii=0,1
+               i=ivik(iv)+ii
+               phisim(iv)=phisim(iv)+zw(ii,jj,iv)*phis(i,j)
+            ENDDO
+         ENDDO
+      ENDDO
+      PRINT*,'relief aux points Viking pour les sorties:',phivik
+
+c----------------------------------------------------------------------
+c   lectures des etats:
+c   -------------------
+
+       airtot1=1./(SSUM(ip1jmp1,aire,1)-SSUM(jjp1,aire,iip1))
+
+c======================================================================
+c   debut de la boucle sur les etats dans un fichier histoire:
+c======================================================================
+       count_ps=(/iip1,jjp1,1/)
+       count_co2ice=(/iip1,jjp1,1/)
+       count_temp=(/iip1,jjp1,llm,1/)
+       
+       DO itau=1,nbpas
+
+       start_ps=(/1,1,itau/)
+       start_co2ice=(/1,1,itau/)
+       start_temp=(/1,1,1,itau/)
+c   lecture drs des champs:
+c   -----------------------
+c         varname='u'
+c         ierr=drsread (unitlec,varname,unat,itau)
+c         PRINT*,'unat',unat(iip1/2,jjp1/2,llm/2)
+c         varname='v'
+c         ierr=drsread (unitlec,varname,vnat,itau)
+c         PRINT*,'vnat',vnat(iip1/2,jjp1/2,llm/2)
+
+ccccccccc  LECTURE Ps ccccccccccccccccccccccccccc
+          ierr = NF_INQ_VARID (nid, "ps", nvarid)
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start_ps,count_ps, ps)
+#else
+          ierr = NF_GET_VARA_REAL(nid, nvarid,start_ps,count_ps, ps)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'xvik: Lecture echouee pour <ps>'
+            CALL abort
+          ENDIF
+          
+          PRINT*,'ps',ps(iip1/2,jjp1/2)
+
+ccccccccc  LECTURE Temperature ccccccccccccccccccccccccccc
+          ierr = NF_INQ_VARID (nid, "temp", nvarid)
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start_temp,count_temp, t)
+#else
+          ierr = NF_GET_VARA_REAL(nid,nvarid,start_temp,count_temp, t)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'xvik: Lecture echouee pour <temp>'
+            CALL abort
+          ENDIF
+
+c          PRINT*,'t',t(iip1/2,jjp1/2,llm/2)
+
+ccccccccc  LECTURE co2ice ccccccccccccccccccccccccccc
+          ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
+#ifdef NC_DOUBLE
+          ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start_co2ice,
+     &    count_co2ice,  co2ice)
+#else
+          ierr = NF_GET_VARA_REAL(nid, nvarid,start_co2ice,
+     &    count_co2ice, co2ice)
+#endif
+          IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, 'xvik: Lecture echouee pour <co2ice>'
+            CALL abort
+          ENDIF
+
+
+c Gestion du temps
+c ----------------
+          day=temps(itau)
+          PRINT*,'day ',day
+          CALL solarlong(day+day0,sollong)
+          sol=day+day0+461.
+          iyear=sol/unanj
+          WRITE (*,*) 'iyear',iyear
+          sol=sol-iyear*unanj
+c
+c Ouverture / fermeture des fichiers
+c ----------------------------------
+          IF (iyear.NE.kyear) THEN
+             WRITE(chr2(1:1),'(i1)') iyear+1
+             WRITE (*,*) 'iyear bis',iyear
+             WRITE (*,*) 'chr2'
+             WRITE (*,*)  chr2
+             IF(iyear.GE.9) WRITE(chr2,'(i2)') iyear+1
+             kyear=iyear
+             DO ii=1,2
+                CLOSE(10+ifile(ii))
+                CLOSE(2+ifile(ii))
+                CLOSE(4+ifile(ii))
+                CLOSE(6+ifile(ii))
+                CLOSE(8+ifile(ii))
+                CLOSE(16+ifile(ii))
+                CLOSE(12+ifile(ii))
+                CLOSE(14+ifile(ii))
+                CLOSE(97)
+                CLOSE(98)
+             ENDDO
+             CLOSE(5+ifile(1))
+             OPEN(ifile(1)+10,file='xpsol1'//chr2,form='formatted')
+             OPEN(ifile(2)+10,file='xpsol2'//chr2,form='formatted')
+c            OPEN(ifile(1)+8,file='xbpsol1'//chr2,form='formatted')
+c            OPEN(ifile(2)+8,file='xbpsol2'//chr2,form='formatted')
+c            OPEN(ifile(1)+2,file='xlps1'//chr2,form='formatted')
+c            OPEN(ifile(2)+2,file='xlps2'//chr2,form='formatted')
+             IF(lcal) THEN
+c               OPEN(ifile(2)+4,file='xpressud'//chr2,form='formatted')
+c               OPEN(ifile(1)+4,file='xpresnord'//chr2,form='formatted')
+c               OPEN(ifile(1)+6,file='xpm2'//chr2,form='formatted')
+             ENDIF
+                         IF(latcal) THEN
+c               OPEN(ifile(2)+14,file='xlats'//chr2,form='formatted')
+c               OPEN(ifile(1)+14,file='xlatn'//chr2,form='formatted')
+                         ENDIF
+             IF(lvent) THEN
+c               OPEN(ifile(1)+16,file='xu1'//chr2,form='formatted')
+c               OPEN(ifile(2)+16,file='xu2'//chr2,form='formatted')
+c               OPEN(ifile(1)+12,file='xv1'//chr2,form='formatted')
+c               OPEN(ifile(2)+12,file='xv2'//chr2,form='formatted')
+             ENDIF
+             OPEN(97,file='xprestot'//chr2,form='formatted')
+c            OPEN(98,file='xlat37_'//chr2,form='formatted')
+           WRITE(98,'(f5.1,16f7.1)') 0.,(rlonv(i)*180./pi,i=1,iim,4)
+          ENDIF
+ 
+
+          sollong=sollong*180./pi
+          IF(day_ls) THEN
+             dayw=sol
+             write(*,*) 'dayw', dayw
+          ELSE
+             dayw=sollong
+          ENDIF
+
+c Calcul de la moyenne planetaire
+c -------------------------------
+          pstot=0.
+          captotS=0.
+          captotN=0.
+          DO j=1,jjp1
+             DO i=1,iim
+                pstot=pstot+aire(i,j)*ps(i,j)
+             ENDDO
+          ENDDO
+ 
+              DO j=1,jjp1/2
+                 DO i=1,iim
+                    captotN = captotN  +aire(i,j)*co2ice(i,j)
+                 ENDDO
+              ENDDO
+              DO j=jjp1/2+1, jjp1
+                 DO i=1,iim
+                    captotS = captotS  +aire(i,j)*co2ice(i,j)
+                 ENDDO
+              ENDDO
+              WRITE(97,'(4e16.6)') dayw,pstot*airtot1
+     &       , captotN*g*airtot1, captotS*g*airtot1          
+
+          IF(.NOT.firstcal) THEN
+         WRITE(98,'(f5.1,16f7.3)')
+     s    dayw,(ps(i,37),i=1,iim,4)
+
+c boucle sur les sites vikings:
+c ----------------------------
+
+          DO iv=1,2
+
+c interpolation de la temperature dans la 7eme couche, de la pression
+c de surface et des vents aux points viking.
+
+             zp1=0.
+             zp2=0.
+             zp2_sm=0.
+             zt=0.
+             zu=0.
+             zv=0.
+             DO jj=0,1
+                j=jvik(iv)+jj
+                DO ii=0,1
+                   i=ivik(iv)+ii
+                   zt=zt+zw(ii,jj,iv)*t(i,j,7)
+                   zp1=zp1+zw(ii,jj,iv)*ps(i,j)
+                    WRITE (*,*) 'ps autour iv',ps(i,j),iv
+                   zu=zu+zw(ii,jj,iv)*unat(i,j,1)/cu(i,j)
+                   zv=zv+zw(ii,jj,iv)*vnat(i,j,1)/cv(i,j)
+                ENDDO
+             ENDDO
+ 
+ 
+c               pression au sol extrapolee a partir de la temp. 7eme couche
+           WRITE (*,*) 'constR ',constR 
+           WRITE (*,*) 'zt ',zt 
+                gh=constR*zt
+                zp2=zp1*exp(-(phivik(iv)-phisim(iv))/gh)
+
+           WRITE (*,*) 'iv,pstot,zp2, zp1, phivik(iv),phisim(iv),gh'
+           WRITE (*,*) iv,pstot*airtot1,zp2,zp1,phivik(iv),phisim(iv),gh
+           WRITE(ifile(iv)+10,'(2e15.5)') dayw,zp1
+
+           
+c   sorties eventuelles de vent
+             IF(lvent) THEN
+                WRITE(ifile(iv)+16,'(2e15.5)')
+     s          dayw,zu
+                WRITE(ifile(iv)+12,'(2e15.5)')
+     s          dayw,zv
+             ENDIF
+          ENDDO
+c         IF (lcal) THEN
+c            WRITE(ifile(1)+4,'(2e15.6)') dayw,airtot1*g*.01*
+c    s       (SSUM(ip1jmp1/2,ziceco2,1)-SSUM(jjp1/2,ziceco2,iip1))
+c            WRITE(ifile(2)+4,'(2e15.6)') dayw,airtot1*g*.01*
+c    s       (SSUM(iip1*jjm/2,ziceco2(1,jjm/2+2),1)-
+c    s       SSUM(jjm/2,ziceco2(1,jjm/2+2),iip1))
+c         ENDIF
+c            IF(latcal) THEN
+c               CALL icelat(iim,jjm,ziceco2,rlatv,zicelat)
+c               WRITE(ifile(1)+14,'(2e15.6)') dayw,zicelat(1)*180./pi
+c               WRITE(ifile(2)+14,'(2e15.6)') dayw,zicelat(2)*180./pi
+c            ENDIF
+         ENDIF
+         firstcal=.false.
+
+c======================================================================
+c   Fin de la boucle sur les etats du fichier histoire:
+c======================================================================
+      ENDDO
+
+      ierr= NF_CLOSE(nid)
+
+      PRINT*,'Fin du fichier',nomfich
+      print*,'Entrer un nouveau fichier ou return pour finir'
+      READ(5,'(a)',err=9999) nomfich
+
+c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+c   Fin de la boucle sur les fichiers histoire:
+c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+      ENDDO
+
+      PRINT*,'relief du point V1',.001*phis(ivik(1),jvik(1))/g
+      PRINT*,'relief du point V2',.001*phis(ivik(2),jvik(2))/g
+      DO iv=1,2
+         PRINT*,'Viking',iv,'   i=',ivik(iv),'j  =',jvik(iv)
+         WRITE(6,7777)
+     s   (rlonv(i)*180./pi,i=ivik(iv)-1,ivik(iv)+2)
+         print*
+         DO j=jvik(iv)-1,jvik(iv)+2
+            WRITE(6,'(f8.1,10x,5f7.1)')
+     s   rlatu(j)*180./pi,(phis(i,j)/(g*1000.),i=ivik(iv)-1,ivik(iv)+2)
+         ENDDO
+         print*
+         print*,'zw'
+         write(6,'(2(2f10.4/))') ((zw(ii,jj,iv),ii=0,1),jj=0,1)
+         print*,'altitude interpolee (km) ',phisim(iv)/1000./g
+      ENDDO
+      PRINT*,'R=',r
+ 9999  PRINT*,'Fin '
+
+7777  FORMAT ('latitude/longitude',4f7.1)
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Entries
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Entries	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Entries	(revision 57)
@@ -0,0 +1,10 @@
+/acc.F/1.1.1.1/Mon Nov 22 15:02:04 1999//Trel-1-0-patch
+/coefils.h/1.1.1.1/Mon Nov 22 15:02:05 1999//Trel-1-0-patch
+/eigen.F/1.1.1.1/Mon Nov 22 15:02:05 1999//Trel-1-0-patch
+/eigen_sort.F/1.1.1.1/Mon Nov 22 15:02:05 1999//Trel-1-0-patch
+/filtreg.F/1.2/Thu Mar 29 14:58:49 2001//Trel-1-0-patch
+/inifgn.F/1.1.1.1/Mon Nov 22 15:02:05 1999//Trel-1-0-patch
+/inifilr.F/1.1.1.1/Mon Nov 22 15:02:05 1999//Trel-1-0-patch
+/jacobi.F/1.2/Thu Mar 29 14:58:49 2001//Trel-1-0-patch
+/parafilt.h/1.2/Thu Mar 29 14:58:49 2001//Trel-1-0-patch
+D
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Repository
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Repository	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Repository	(revision 57)
@@ -0,0 +1,1 @@
+LMDZ.3.3/libf/filtrez
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Root
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Root	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Root	(revision 57)
@@ -0,0 +1,1 @@
+:pserver:lmdzbrowse@piaf.lmd.jussieu.fr:/users/lmdz/cvsroot
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Tag
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Tag	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/CVS/Tag	(revision 57)
@@ -0,0 +1,1 @@
+Trel-1-0-patch
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/acc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/acc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/acc.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/coefils.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/coefils.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/coefils.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen_sort.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen_sort.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/eigen_sort.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/filtreg.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/filtreg.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/filtreg.F	(revision 57)
@@ -0,0 +1,297 @@
+      SUBROUTINE filtreg ( champ, nlat, nbniv, ifiltre,iaire,
+     .   griscal ,iter)
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Auteur: P. Le Van        07/10/97
+c   ------
+c
+c   Objet: filtre matriciel longitudinal ,avec les matrices precalculees
+c                     pour l'operateur  Filtre    .
+c   ------
+c
+c   Arguments:
+c   ----------
+c
+c      nblat                 nombre de latitudes a filtrer
+c      nbniv                 nombre de niveaux verticaux a filtrer
+c      champ(iip1,nblat,nbniv)  en entree : champ a filtrer
+c                            en sortie : champ filtre
+c      ifiltre               +1  Transformee directe
+c                            -1  Transformee inverse
+c                            +2  Filtre directe
+c                            -2  Filtre inverse
+c
+c      iaire                 1   si champ intensif
+c                            2   si champ extensif (pondere par les aires)
+c
+c      iter                  1   filtre simple
+c
+c=======================================================================
+c
+c
+c                      Variable Intensive
+c                ifiltre = 1     filtre directe
+c                ifiltre =-1     filtre inverse
+c
+c                      Variable Extensive
+c                ifiltre = 2     filtre directe
+c                ifiltre =-2     filtre inverse
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+#include "parafilt.h"
+#include "coefils.h"
+c
+      INTEGER nlat,nbniv,ifiltre,iter
+      INTEGER i,j,l,k
+      INTEGER iim2,immjm
+      INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil
+
+      REAL  champ( iip1,nlat,nbniv)
+      REAL matriceun,matriceus,matricevn,matricevs,matrinvn,matrinvs
+      COMMON/matrfil/matriceun(iim,iim,nfilun),matriceus(iim,iim,nfilus)
+     ,             , matricevn(iim,iim,nfilvn),matricevs(iim,iim,nfilvs)
+     ,             ,  matrinvn(iim,iim,nfilun),matrinvs (iim,iim,nfilus)
+      REAL  eignq(iim), sdd1(iim),sdd2(iim)
+      LOGICAL    griscal
+      INTEGER    hemisph, iaire
+c
+
+      IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) 
+     *    STOP'Pas de transformee simple dans cette version'
+
+      IF( iter.EQ. 2 )  THEN
+       PRINT *,' Pas d iteration du filtre dans cette version !'
+     * , ' Utiliser old_filtreg et repasser !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.EQ. -2 .AND..NOT.griscal )     THEN
+       PRINT *,' Cette routine ne calcule le filtre inverse que ',
+     * ' sur la grille des scalaires !'
+           STOP
+      ENDIF
+
+      IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 )  THEN
+       PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2'
+     *,' corriger et repasser !'
+           STOP
+      ENDIF
+c
+
+      iim2   = iim * iim
+      immjm  = iim * jjm
+c
+c
+      IF( griscal )   THEN
+         IF( nlat. NE. jjp1 )  THEN
+             PRINT  1111
+             STOP
+         ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddv, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddv, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddv, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddv, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 2
+             jffil1 = jfiltnu
+             jdfil2 = jfiltsu
+             jffil2 = jjm
+          END IF
+      ELSE
+          IF( nlat.NE.jjm )  THEN
+             PRINT  2222
+             STOP
+          ELSE
+c
+             IF( iaire.EQ.1 )  THEN
+                CALL SCOPY(  iim,    sddu, 1,  sdd1, 1 ) 
+                CALL SCOPY(  iim,  unsddu, 1,  sdd2, 1 )
+             ELSE
+                CALL SCOPY(  iim,  unsddu, 1,  sdd1, 1 )
+                CALL SCOPY(  iim,    sddu, 1,  sdd2, 1 )
+             END IF
+c
+             jdfil1 = 1
+             jffil1 = jfiltnv
+             jdfil2 = jfiltsv
+             jffil2 = jjm
+          END IF
+      END IF
+c
+c
+      DO 100  hemisph = 1, 2
+c
+      IF ( hemisph.EQ.1 )  THEN
+          jdfil = jdfil1
+          jffil = jffil1
+      ELSE
+          jdfil = jdfil2
+          jffil = jffil2
+      END IF
+
+ 
+      DO 50  l = 1, nbniv
+      DO 30  j = jdfil,jffil
+ 
+ 
+      DO  5  i = 1, iim
+      champ(i,j,l) = champ(i,j,l) * sdd1(i)
+   5  CONTINUE
+c
+
+      IF( hemisph. EQ. 1 )      THEN
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvn(1,1,j), 1, iim, champ(1,j,l), 1, eignq  , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO k = 1, iim
+      DO i = 1, iim
+         eignq(k) = eignq(k) + matrinvn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceun(1,1,j), 1, iim, champ(1,j,l), 1, eignq ,
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceun(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceun(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevn(1,1,j), 1, iim, champ(1,j,l), 1, eignq , 
+     *                             1, iim, iim                         )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevn(1,1,j),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevn(k,i,j)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ELSE
+
+        IF( ifiltre. EQ. -2 )   THEN
+#ifdef CRAY
+         CALL MXVA( matrinvs(1,1,j-jfiltsu+1),  1, iim, champ(1,j,l),1 ,  
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matrinvs(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matrinvs(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE IF ( griscal )     THEN
+#ifdef CRAY
+         CALL MXVA( matriceus(1,1,j-jfiltsu+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matriceus(1,1,j-jfiltsu+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matriceus(k,i,j-jfiltsu+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ELSE 
+#ifdef CRAY
+         CALL MXVA( matricevs(1,1,j-jfiltsv+1), 1, iim, champ(1,j,l),1 , 
+     *                          eignq,  1, iim, iim                    )
+#else
+#ifdef BLAS
+      CALL SGEMV("N", iim,iim, 1.0, matricevs(1,1,j-jfiltsv+1),iim,
+     .           champ(1,j,l), 1, 0.0, eignq, 1)
+#else
+      DO k = 1, iim
+         eignq(k) = 0.0
+      ENDDO
+      DO i = 1, iim
+      DO k = 1, iim
+         eignq(k) = eignq(k) + matricevs(k,i,j-jfiltsv+1)*champ(i,j,l)
+      ENDDO
+      ENDDO
+#endif
+#endif
+        ENDIF
+
+      ENDIF
+c
+      IF( ifiltre.EQ. 2 )  THEN
+        DO 15 i = 1, iim
+        champ( i,j,l ) = ( champ(i,j,l) + eignq(i) ) * sdd2(i)
+  15    CONTINUE
+      ELSE
+        DO 16 i=1,iim
+        champ( i,j,l ) = ( champ(i,j,l) - eignq(i) ) * sdd2(i)
+16      CONTINUE
+      ENDIF
+c
+      champ( iip1,j,l ) = champ( 1,j,l )
+c
+  30  CONTINUE
+c
+  50  CONTINUE
+c    
+ 100  CONTINUE
+c
+1111  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau  CHAMP a 
+     *filtrer, sur la grille des scalaires'/)
+2222  FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi
+     *ltrer, sur la grille de V ou de Z'/)
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifgn.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifgn.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifgn.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifilr.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifilr.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/inifilr.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/jacobi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/jacobi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/jacobi.F	(revision 57)
@@ -0,0 +1,94 @@
+      SUBROUTINE JACOBI(A,N,NP,D,V,NROT)
+      PARAMETER (NMAX=400)
+      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
+      IF (n.gt.nmax) THEN
+         print*, 'n, nmax=', n, nmax
+         print*, 'Surdimensionnement insuffisant dans jacobi'
+         CALL abort
+      ENDIF
+      DO 12 IP=1,N
+        DO 11 IQ=1,N
+          V(IP,IQ)=0.
+11      CONTINUE
+        V(IP,IP)=1.
+12    CONTINUE
+      DO 13 IP=1,N
+        B(IP)=A(IP,IP)
+        D(IP)=B(IP)
+        Z(IP)=0.
+13    CONTINUE
+      NROT=0
+      DO 24 I=1,50
+        SM=0.
+        DO 15 IP=1,N-1
+          DO 14 IQ=IP+1,N
+            SM=SM+ABS(A(IP,IQ))
+14        CONTINUE
+15      CONTINUE
+        IF(SM.EQ.0.)RETURN
+        IF(I.LT.4)THEN
+          TRESH=0.2*SM/N**2
+        ELSE
+          TRESH=0.
+        ENDIF
+        DO 22 IP=1,N-1
+          DO 21 IQ=IP+1,N
+            G=100.*ABS(A(IP,IQ))
+            IF((I.GT.4).AND.(ABS(D(IP))+G.EQ.ABS(D(IP)))
+     *         .AND.(ABS(D(IQ))+G.EQ.ABS(D(IQ))))THEN
+              A(IP,IQ)=0.
+            ELSE IF(ABS(A(IP,IQ)).GT.TRESH)THEN
+              H=D(IQ)-D(IP)
+              IF(ABS(H)+G.EQ.ABS(H))THEN
+                T=A(IP,IQ)/H
+              ELSE
+                THETA=0.5*H/A(IP,IQ)
+                T=1./(ABS(THETA)+SQRT(1.+THETA**2))
+                IF(THETA.LT.0.)T=-T
+              ENDIF
+              C=1./SQRT(1+T**2)
+              S=T*C
+              TAU=S/(1.+C)
+              H=T*A(IP,IQ)
+              Z(IP)=Z(IP)-H
+              Z(IQ)=Z(IQ)+H
+              D(IP)=D(IP)-H
+              D(IQ)=D(IQ)+H
+              A(IP,IQ)=0.
+              DO 16 J=1,IP-1
+                G=A(J,IP)
+                H=A(J,IQ)
+                A(J,IP)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+16            CONTINUE
+              DO 17 J=IP+1,IQ-1
+                G=A(IP,J)
+                H=A(J,IQ)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(J,IQ)=H+S*(G-H*TAU)
+17            CONTINUE
+              DO 18 J=IQ+1,N
+                G=A(IP,J)
+                H=A(IQ,J)
+                A(IP,J)=G-S*(H+G*TAU)
+                A(IQ,J)=H+S*(G-H*TAU)
+18            CONTINUE
+              DO 19 J=1,N
+                G=V(J,IP)
+                H=V(J,IQ)
+                V(J,IP)=G-S*(H+G*TAU)
+                V(J,IQ)=H+S*(G-H*TAU)
+19            CONTINUE
+              NROT=NROT+1
+            ENDIF
+21        CONTINUE
+22      CONTINUE
+        DO 23 IP=1,N
+          B(IP)=B(IP)+Z(IP)
+          D(IP)=B(IP)
+          Z(IP)=0.
+23      CONTINUE
+24    CONTINUE
+      STOP '50 iterations should never happen'
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/parafilt.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/parafilt.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/filtrez/parafilt.h	(revision 57)
@@ -0,0 +1,40 @@
+        INTEGER nfilun, nfilus, nfilvn, nfilvs
+c
+c 48 32 19 non-zoom:
+c       PARAMETER (nfilun=30,nfilus=30,nfilvn=30,nfilvs=30)
+c        PARAMETER (nfilun=6, nfilus=5, nfilvn=5, nfilvs=5)
+c         PARAMETER (nfilun=15, nfilus=8, nfilvn=14, nfilvs=8)
+c        PARAMETER (nfilun=24, nfilus=23, nfilvn=24, nfilvs=24)
+cmaf -debug  PARAMETER (nfilun=2, nfilus=1, nfilvn=2, nfilvs=2)
+c
+c
+c 96 49 11 non-zoom:
+ccc      PARAMETER (nfilun=9, nfilus=8, nfilvn=8, nfilvs=8)
+c
+c
+c 144 73 11 non-zoom:
+ccc      PARAMETER (nfilun=13, nfilus=12, nfilvn=12, nfilvs=12)
+c
+c 192 143 19 non-zoom:
+c             PARAMETER (nfilun=13, nfilus=12, nfilvn=13, nfilvs=13)
+c      PARAMETER (nfilun=15, nfilus=14, nfilvn=14, nfilvs=14) !!NO fxyhyper
+       PARAMETER (nfilun=18, nfilus=17, nfilvn=17, nfilvs=17) !!NO fxyhyper
+c       PARAMETER (nfilun=9,nfilus=8,nfilvn=8,nfilvs=8)
+
+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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.1.1.32.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.1.1.32.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.1.1.32.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.10.48.55.t6
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.10.48.55.t6	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.10.48.55.t6	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 10
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=55
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=6
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.25.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.24.32.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=32
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.16.32.25.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 16
+      INTEGER, parameter :: jjm=32
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.176.90.18.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.176.90.18.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.176.90.18.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 176
+      INTEGER, parameter :: jjm=90
+      INTEGER, parameter :: llm=18
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.2.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.2.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.2.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=2
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t32
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t32	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.25.t32	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=32
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.32.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t13
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t13	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t13	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=13
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.50.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=60
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t12
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t12	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t12	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=60
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=12
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=60
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t60
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t60	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.24.60.t60	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=24
+      INTEGER, parameter :: llm=60
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=60
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.34.60.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.34.60.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.34.60.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 32
+      INTEGER, parameter :: jjm=34
+      INTEGER, parameter :: llm=60
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.32.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.50.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 1
+      INTEGER, parameter :: jjm=1
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.18.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.18.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.18.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=18
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.24.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.24.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.24.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=24
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t-p
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t-p	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t-p	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=-p
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.25.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=25
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t12
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t12	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t12	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=12
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t13
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t13	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t13	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=13
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.32.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.325.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.325.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.325.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=325
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t1	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=1
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t15
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t15	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.50.t15	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=50
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=15
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t14
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t14	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t14	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=54
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=14
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.64.48.54.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 64
+      INTEGER, parameter :: jjm=48
+      INTEGER, parameter :: llm=54
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.72.36.32.t2
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.72.36.32.t2	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/dimensions.72.36.32.t2	(revision 57)
@@ -0,0 +1,16 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h continet les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= 72
+      INTEGER, parameter :: jjm=36
+      INTEGER, parameter :: llm=32
+      INTEGER, parameter :: ndm=1
+
+      integer, parameter :: nqmx=2
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim	(revision 57)
@@ -0,0 +1,66 @@
+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
+
+#  while [ "$n2" -gt 2 ]; do
+#      n2=`expr $n2 / 2`
+#     ndm=`expr $ndm + 1`
+#   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
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimensions.h'
+!
+!   dimensions.h contient les dimensions du modele
+!   ndm est tel que iim=2**ndm
+!   nqmx est la dimension de la variable traceur q
+!-----------------------------------------------------------------------
+
+      INTEGER, parameter :: iim= $im
+      INTEGER, parameter :: jjm=$jm
+      INTEGER, parameter :: llm=$lm
+      INTEGER, parameter :: ndm=$ndm
+
+      integer, parameter :: nqmx=$nqmx
+
+!-----------------------------------------------------------------------
+EOF
+fi
+
+\rm ../dimensions.h
+tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h )
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.bak
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.bak	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.bak	(revision 57)
@@ -0,0 +1,63 @@
+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
+   while [ "$n2" -gt 2 ]; do
+      n2=`expr $n2 / 2`
+      ndm=`expr $ndm + 1`
+   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 continet 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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.moi
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.moi	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.moi	(revision 57)
@@ -0,0 +1,68 @@
+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
+
+echo $#
+if [ $# -ge 3 ] ; then
+   im=$1
+   jm=$2
+   lm=$3
+   n2=$1
+   ndm=1
+
+#  while [ "$n2" -gt 2 ]; do
+#      n2=`expr $n2 / 2`
+#     ndm=`expr $ndm + 1`
+#   done
+#   if [ "$n2" != 2 ] ; then
+#      echo le nombre de longitude doit etre une puissance de 2
+#      exit
+#   fi
+
+echo $#
+    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 continet 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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.n
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.n	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.n	(revision 57)
@@ -0,0 +1,65 @@
+for i in $* ; do
+   list=$list.$i
+done
+fichdim=dimensions$list
+
+if [ ! -f $fichdim ] ; then
+# si le fichier de dimensions n'existe pas, on le cree
+
+if [ $# -ge 4 ] ; then
+   nqmx=$1
+   im=$2
+   jm=$3
+   lm=$4
+   n2=$2
+   ndm=1
+   while [ "$n2" -gt 2 ]; do
+      n2=`expr $n2 / 2`
+      ndm=`expr $ndm + 1`
+   done
+   if [ "$n2" != 2 ] ; then
+      echo le nombre de longitude doit etre une puissance de 2
+      exit
+   fi
+else if [ $# -ge 3 ] ; then
+   nqmx=$1
+   im=1
+   jm=$2
+   lm=$3
+   ndm=1
+   else if [ $# -ge 2 ] ; then
+      nqmx=$1
+      im=1
+      jm=1
+      lm=$2
+      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 continet 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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.old
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.old	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdim.old	(revision 57)
@@ -0,0 +1,57 @@
+for i in $* ; do
+   list=$list.$i
+done
+fichdim=dimensions$list
+
+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
+   while [ "$n2" -gt 2 ]; do
+      n2=`expr $n2 / 2`
+      ndm=`expr $ndm + 1`
+   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 continet les trois dimensions du modele
+c   ndm est tel que iim=2**ndm
+c-----------------------------------------------------------------------
+
+      INTEGER iim,jjm,llm,ndm
+
+      PARAMETER (iim= $im,jjm=$jm,llm=$lm,ndm=$ndm)
+
+c-----------------------------------------------------------------------
+EOF
+fi
+
+\rm ../dimensions.h
+tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimensions.h )
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdimphy
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdimphy	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makdimphy	(revision 57)
@@ -0,0 +1,28 @@
+for i in $* ; do
+   list=$list.$i
+done
+fichdim=dimphy$list
+
+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
+else
+   echo il faut preciser les dimensions
+   exit
+fi
+
+cat << EOF > $fichdim
+c-----------------------------------------------------------------------
+      INTEGER KIDIA, KFDIA, KLON, KLEV
+      PARAMETER (KIDIA=1,KFDIA=$im*($jm-1)+2,
+     .           KLON=KFDIA-KIDIA+1,KLEV=$lm)
+c-----------------------------------------------------------------------
+EOF
+fi
+
+/bin/rm ../dimphy.h
+tar cf - $fichdim | ( cd .. ; tar xf - ; mv $fichdim dimphy.h )
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makntrac
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makntrac	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/makntrac	(revision 57)
@@ -0,0 +1,23 @@
+fichntrac=ntraceur.$1
+
+if [ ! -f $fichntrac ] ; then
+# si le fichier de dimensions n'existe pas, on le cree
+
+cat << EOF > $fichntrac
+c-----------------------------------------------------------------------
+c   INCLUDE 'ntraceur.h'
+c
+c   ntraceur.h contient la dimension de la variable traceur q
+c   Generalement egale au nombre de traceur.
+c-----------------------------------------------------------------------
+
+      INTEGER nqmx
+
+      PARAMETER (nqmx=$1)
+
+c-----------------------------------------------------------------------
+EOF
+fi
+
+\rm ../ntraceur.h
+tar cf - $fichntrac | ( cd .. ; tar xf - ; mv $fichntrac ntraceur.h )
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.1
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.1	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.1	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'ntraceur.h'
+c
+c   ntraceur.h contient la dimension de la variable traceur q
+c   Generalement egale au nombre de traceur.
+c-----------------------------------------------------------------------
+
+      INTEGER nqmx
+
+      PARAMETER (nqmx=1)
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.5
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.5	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/dimension/ntraceur.5	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'ntraceur.h'
+c
+c   ntraceur.h contient la dimension de la variable traceur q
+c   Generalement egale au nombre de traceur.
+c-----------------------------------------------------------------------
+
+      INTEGER nqmx
+
+      PARAMETER (nqmx=5)
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_new.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_new.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_new.h	(revision 57)
@@ -0,0 +1,21 @@
+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--------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_reg.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_reg.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_reg.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_sin.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_sin.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxy_sin.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxyprim.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxyprim.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/grid/fxyprim.h	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerave.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerave.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerave.F	(revision 57)
@@ -0,0 +1,189 @@
+      SUBROUTINE aerave ( ndata,
+     & longdata,epdata,omegdata,gdata,          
+     &            longref,epref,temp,nir,longir
+     &            ,epir,omegir,gir                      )
+      IMPLICIT NONE
+c.......................................................................
+c
+c R.Fournier 02/1996 
+c (modif F.Forget 02/1996)
+c le spectre est decoupe en "nir" bandes et cette routine calcule
+c les donnees radiatives moyenne sur chaque bande : l'optimisation
+c est faite pour une temperature au sol "temp" et une epaisseur
+c optique de l'atmosphere "epref" a la longueur d'onde "longref"
+c
+c dans la version actuelle, les ponderations sont independantes de
+c l'epaisseur optique : c'est a dire que "omegir", "gir"
+c et "epir/epre" sont independants de "epref".
+c en effet les ponderations sont choisies pour une solution exacte
+c en couche mince et milieu isotherme. 
+c
+c entree
+c
+c    ndata : taille des champs data
+c    longdata,epdata,omegdata,gdata : proprietes radiative de l'aerosol
+c                  (longdata longueur d'onde en METRES)
+c  * longref : longueur d'onde a laquelle l'epaisseur optique
+c              est connue
+c  * epref : epaisseur optique a longref
+c  * temp : temperature choisie pour la ponderation (Planck)
+c  * nir : nombre d'intervals dans la discretisation spectrale
+c           du GCM
+c  * longir : longueurs d'onde definissant ces intervals
+c
+c sortie
+c
+c  * epir : epaisseur optique moyenne pour chaque interval
+c  * omegir : "scattering albedo" moyen pour chaque interval
+c  * gir : "assymetry factor" moyen pour chaque interval
+c
+c.......................................................................
+c
+      REAL longref
+      REAL epref
+      REAL temp
+      INTEGER nir
+      REAL longir(nir+1)
+      REAL epir(nir)
+      REAL omegir(nir)
+      REAL gir(nir)
+c
+c.......................................................................
+c
+      INTEGER iir,nirmx
+      PARAMETER (nirmx=100)
+      INTEGER idata,ndata
+c
+c.......................................................................
+c
+      REAL emit
+      REAL totalemit(nirmx)
+      REAL longdata(ndata),epdata(ndata)
+     &    ,omegdata(ndata),gdata(ndata)
+      INTEGER ibande,nbande
+      PARAMETER (nbande=1000)
+      REAL long,deltalong
+      INTEGER ilong
+      INTEGER i1,i2
+      REAL c1,c2
+      REAL factep,ep,omeg,g
+c
+c.......................................................................
+c
+      DOUBLE PRECISION tmp1
+      REAL tmp2,tmp3
+c
+c
+      long=longref
+c
+c********************************************************
+c interpolation
+      ilong=1
+      DO idata=2,ndata
+        IF (long.gt.longdata(idata)) ilong=idata
+      ENDDO
+      i1=ilong
+      i2=ilong+1
+      IF (i2.gt.ndata) i2=ndata
+      IF (long.lt.longdata(1)) i2=1
+      IF (i1.eq.i2) THEN
+        c1=1.E+0
+        c2=0.E+0
+      ELSE
+        c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+        c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+      ENDIF
+c********************************************************
+c
+      ep=c1*epdata(i1)+c2*epdata(i2)
+      factep=ep/epref
+      DO idata=1,ndata
+        epdata(idata)=epdata(idata)/factep
+      ENDDO
+c
+c.......................................................................
+c
+      DO iir=1,nir
+c
+c.......................................................................
+c
+        deltalong=(longir(iir+1)-longir(iir)) / nbande
+        totalemit(iir)=0.E+0
+        epir(iir)=0.E+0
+        omegir(iir)=0.E+0
+        gir(iir)=0.E+0
+c
+c.......................................................................
+c
+        DO ibande=1,nbande
+c
+c.......................................................................
+c
+          long=longir(iir) + (ibande-0.5E+0) * deltalong
+          CALL blackl(DBLE(long),DBLE(temp),tmp1)
+          emit=REAL(tmp1)
+c
+c.......................................................................
+c
+c********************************************************
+c interpolation
+      ilong=1
+      DO idata=2,ndata
+        IF (long.gt.longdata(idata)) ilong=idata
+      ENDDO
+      i1=ilong
+      i2=ilong+1
+      IF (i2.gt.ndata) i2=ndata
+      IF (long.lt.longdata(1)) i2=1
+      IF (i1.eq.i2) THEN
+        c1=1.E+0
+        c2=0.E+0
+      ELSE
+        c1=(longdata(i2)-long) / (longdata(i2)-longdata(i1))
+        c2=(longdata(i1)-long) / (longdata(i1)-longdata(i2))
+      ENDIF
+c********************************************************
+c
+          ep=c1*epdata(i1)+c2*epdata(i2)
+          omeg=c1*omegdata(i1)+c2*omegdata(i2)
+          g=c1*gdata(i1)+c2*gdata(i2)
+c
+c.......................................................................
+c
+          totalemit(iir)=totalemit(iir)+deltalong*emit
+          epir(iir)=epir(iir)+deltalong*emit*ep
+          omegir(iir)=omegir(iir)+deltalong*emit*omeg*ep
+          gir(iir)=gir(iir)+deltalong*emit*omeg*ep*g
+c
+c.......................................................................
+c
+        ENDDO
+c
+c.......................................................................
+c
+        gir(iir)=gir(iir)/omegir(iir)
+        omegir(iir)=omegir(iir)/epir(iir)
+        epir(iir)=epir(iir)/totalemit(iir)
+c
+c.......................................................................
+c
+      ENDDO
+c
+c......................................................................
+c
+c     Diagnostic de controle si on moyenne sur tout le spectre vis ou IR :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     tmp2=0.E+0
+c     DO iir=1,nir
+c       tmp2=tmp2+totalemit(iir)
+c     ENDDO
+c     tmp3=5.67E-8 * temp**4
+c     IF (abs((tmp2-tmp3)/tmp3).gt.0.05E+0) THEN
+c       PRINT *,'!!!! <---> il manque du Planck (voir moyenne.F)'
+c       PRINT *,'somme des bandes :',tmp2,'--- Planck:',tmp3
+c     ENDIF
+c
+c......................................................................
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdata.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdata.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdata.h	(revision 57)
@@ -0,0 +1,134 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerdata.h'
+c Spectral  Radiative properties of the Martian dust
+c SPECIAL "bright dust" (Clancy and Lee, 1991)
+
+c visible (Clancy and Lee, 1991)
+      integer ndatavis
+      parameter(ndatavis=2)
+      REAL longdatavis(ndatavis),epdatavis(ndatavis)
+     &    ,omegdatavis(ndatavis),gdatavis(ndatavis)
+
+
+c IR (composite: Toon 1977 (5-15micrometers) + Forget, 1996 (>15micrometers) 
+      integer ndatair
+      parameter(ndatair=124)
+      REAL longdatair(ndatair),epdatair(ndatair)
+     &    ,omegdatair(ndatair),gdatair(ndatair)
+
+c Ratio solsir = Tau(vis) / Tau (9 microns)
+      REAL solsir
+      PARAMETER (solsir=2.E+0)
+
+c-----------------------------------------------------------------------
+       
+
+      data longdatavis/
+     & 0.210000E-06,0.414800E-05/
+      data epdatavis/2.5,2.5/
+      data omegdatavis/0.92,0.92/
+      data gdatavis/0.55,0.55/
+      data longdatair/
+     & 0.556000E-05,0.625000E-05,0.714000E-05,0.725000E-05,0.735000E-05
+     &,0.746000E-05,0.758000E-05,0.769000E-05,0.781000E-05,0.794000E-05
+     &,0.800000E-05,0.807000E-05,0.813000E-05,0.820000E-05,0.826000E-05
+     &,0.833000E-05,0.840000E-05,0.848000E-05,0.855000E-05,0.862000E-05
+     &,0.870000E-05,0.877000E-05,0.880000E-05,0.884956E-05,0.892857E-05
+     &,0.900901E-05,0.909091E-05,0.917431E-05,0.925926E-05,0.934579E-05
+     &,0.943396E-05,0.952381E-05,0.961539E-05,0.970874E-05,0.980392E-05
+     &,0.990099E-05,0.100000E-04,0.101010E-04,0.102041E-04,0.103093E-04
+     &,0.104167E-04,0.105263E-04,0.106383E-04,0.107527E-04,0.108696E-04
+     &,0.109890E-04,0.111111E-04,0.112360E-04,0.113636E-04,0.114942E-04
+     &,0.116279E-04,0.117647E-04,0.119048E-04,0.120482E-04,0.121951E-04
+     &,0.123457E-04,0.125000E-04,0.126582E-04,0.128205E-04,0.129870E-04
+     &,0.131579E-04,0.133333E-04,0.135135E-04,0.136986E-04,0.138889E-04
+     &,0.140845E-04,0.142857E-04,0.144928E-04,0.147059E-04,0.149254E-04
+     &,0.151515E-04,0.153846E-04,0.156250E-04,0.158730E-04,0.161290E-04
+     &,0.163934E-04,0.166667E-04,0.169492E-04,0.172414E-04,0.175439E-04
+     &,0.178571E-04,0.181818E-04,0.185185E-04,0.188679E-04,0.192308E-04
+     &,0.196078E-04,0.200000E-04,0.204082E-04,0.208333E-04,0.212766E-04
+     &,0.217391E-04,0.222222E-04,0.227273E-04,0.232558E-04,0.238095E-04
+     &,0.243902E-04,0.250000E-04,0.256410E-04,0.263158E-04,0.270270E-04
+     &,0.277778E-04,0.285714E-04,0.294118E-04,0.303030E-04,0.312500E-04
+     &,0.322581E-04,0.333333E-04,0.344828E-04,0.357143E-04,0.370370E-04
+     &,0.384615E-04,0.400000E-04,0.500000E-04,0.600000E-04,0.700000E-04
+     &,0.800000E-04,0.100000E-03,0.120000E-03,0.140000E-03,0.170000E-03
+     &,0.200000E-03,0.230000E-03,0.260000E-03,0.300000E-03/
+      data epdatair/
+     & 1.8223799,1.3646801,0.6918110,0.6400360,0.6000190
+     &,0.5436750,0.5075750,0.5349990,0.5741300,0.6528150
+     &,0.7026240,0.8045070,0.9152510,0.9964510,1.1199900
+     &,1.2508200,1.4647000,1.6723000,1.7668300,1.8770100
+     &,2.0622301,2.2681601,2.3134601,2.3844199,2.4568000
+     &,2.4623699,2.5139699,2.7634001,3.1062000,3.2699001
+     &,3.0982399,2.8657801,2.7559099,2.6911600,2.6657801
+     &,2.6558800,2.6744900,2.6645300,2.6016099,2.5456300
+     &,2.4316900,2.3356500,2.2314799,2.1130800,2.0792401
+     &,2.0617199,2.0427401,1.9252200,1.9074700,1.9007500
+     &,1.7614900,1.5749300,1.5687200,1.5357200,1.3301001
+     &,1.1643699,1.0552500,1.3750900,1.3406500,1.4579200
+     &,1.2703400,1.2499200,0.9752970,1.0887500,1.0551100
+     &,0.8680390,0.9080590,0.9270510,0.8930280,0.7252980
+     &,0.7761930,0.7722600,0.6197060,0.8046810,0.9906260
+     &,1.1675600,1.3232200,1.4563700,1.5742900,1.6683700
+     &,1.6386300,1.6082799,1.5773100,1.5452300,1.5131000
+     &,1.4803500,1.4470100,1.4130900,1.3785900,1.3430200
+     &,1.3074800,1.2714100,1.2348300,1.1977800,1.1602700
+     &,1.1218801,1.0836500,1.0450701,1.0062100,0.9670900
+     &,0.9273350,0.8879470,0.8485210,0.8090940,0.7697440
+     &,0.7305380,0.6912350,0.6527100,0.6146080,0.5770320
+     &,0.5400900,0.5038810,0.3378440,0.2453480,0.1899010
+     &,0.1543380,0.1124400,0.0889283,0.0739620,0.0593130
+     &,0.0496814,0.0428006,0.0376627,0.0324836/
+      data omegdatair/
+     & 0.9455460,0.9255780,0.6110340,0.5893190,0.4896250
+     &,0.3736060,0.2719810,0.1933450,0.1591350,0.1584020
+     &,0.1842620,0.2511510,0.2616600,0.2910640,0.3243100
+     &,0.3532210,0.3744530,0.3675350,0.3614250,0.3678870
+     &,0.3820890,0.3866010,0.3842250,0.3821830,0.3814160
+     &,0.3779760,0.3837150,0.4103900,0.4473680,0.4952290
+     &,0.5245740,0.5125160,0.4980300,0.4833010,0.4788940
+     &,0.4769360,0.4898900,0.5542500,0.5697640,0.6304710
+     &,0.6634610,0.6500820,0.6469200,0.6292330,0.5847980
+     &,0.5847600,0.6166800,0.6622360,0.6334560,0.6793890
+     &,0.7708860,0.7351760,0.6715080,0.7118780,0.8014710
+     &,0.7203560,0.5123400,0.4070190,0.4575710,0.4804760
+     &,0.5493510,0.5477680,0.5564710,0.5089200,0.5221230
+     &,0.5291490,0.4292840,0.4024670,0.4110070,0.3907940
+     &,0.3085770,0.2905000,0.2411480,0.3065880,0.3493080
+     &,0.3836540,0.4065040,0.4211960,0.4325340,0.4396850
+     &,0.4379220,0.4360720,0.4341270,0.4320340,0.4298880
+     &,0.4276300,0.4252520,0.4227480,0.4201070,0.4172670
+     &,0.4143320,0.4112310,0.4079530,0.4044860,0.4008160
+     &,0.3968690,0.3927530,0.3883870,0.3837510,0.3788250
+     &,0.3735170,0.3679440,0.3620120,0.3556900,0.3489460
+     &,0.3417450,0.3339700,0.3257680,0.3170010,0.3076270
+     &,0.2976060,0.2868930,0.2218360,0.1676840,0.1255320
+     &,0.0942349,0.0544707,0.0330144,0.0214071,0.0119898
+     &,0.0073572,0.0047672,0.0033577,0.0022074/
+      data gdatair/
+     & 0.7727880,0.7891680,0.8149010,0.8143680,0.8141810
+     &,0.8135650,0.8105500,0.8033680,0.7936510,0.7786140
+     &,0.7633720,0.7376310,0.7232250,0.7045770,0.6794170
+     &,0.6532190,0.6216970,0.6061300,0.6006830,0.5882300
+     &,0.5672470,0.5528980,0.5515480,0.5486130,0.5436640
+     &,0.5431460,0.5333350,0.5041380,0.4678710,0.4283810
+     &,0.4064880,0.4156190,0.4282650,0.4454850,0.4535160
+     &,0.4693080,0.4752720,0.4885620,0.5029940,0.5025310
+     &,0.5189140,0.5377080,0.5533670,0.5710530,0.5778970
+     &,0.5762890,0.5706920,0.5760510,0.5783530,0.5683710
+     &,0.5678870,0.5920300,0.5962880,0.5909690,0.5981750
+     &,0.6187920,0.6339570,0.6020770,0.6024800,0.5877340
+     &,0.5985190,0.5957170,0.6125820,0.6001100,0.5978010
+     &,0.6065740,0.5983230,0.5910160,0.5887040,0.5944530
+     &,0.5810070,0.5743440,0.5758550,0.5615340,0.5437820
+     &,0.5243770,0.5039760,0.4829940,0.4609260,0.4389000
+     &,0.4355460,0.4321260,0.4286380,0.4247460,0.4211400
+     &,0.4174550,0.4136880,0.4098350,0.4058920,0.4015100
+     &,0.3974090,0.3932030,0.3888870,0.3844560,0.3799040
+     &,0.3748690,0.3700950,0.3651760,0.3601050,0.3548730
+     &,0.3490900,0.3435280,0.3377980,0.3318590,0.3256990
+     &,0.3192870,0.3122380,0.3053810,0.2982310,0.2907650
+     &,0.2829610,0.2747820,0.2274640,0.1885150,0.1562300
+     &,0.1306820,0.0917524,0.0638560,0.0486232,0.0311882
+     &,0.0219897,0.0157278,0.0129793,0.0101294/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h	(revision 57)
@@ -0,0 +1,135 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerdust.h'
+c Spectral  Radiative properties of the Martian dust
+c SPECIAL "bright dust" (Clancy and Lee, 1991)
+
+
+c visible (Clancy and Lee, 1991)
+      integer ndustvis
+      parameter(ndustvis=2)
+      REAL longdustvis(ndustvis),epdustvis(ndustvis)
+     &    ,omegdustvis(ndustvis),gdustvis(ndustvis)
+
+
+c IR (composite: Toon 1977 (5-15micrometers) + Forget, 1996 (>15micrometers) 
+      integer ndustir
+      parameter(ndustir=124)
+      REAL longdustir(ndustir),epdustir(ndustir)
+     &    ,omegdustir(ndustir),gdustir(ndustir)
+
+c Ratio solsir = Tau(vis) / Tau (9 microns)
+      REAL solsir
+      PARAMETER (solsir=2.E+0)
+
+c-----------------------------------------------------------------------
+       
+
+      data longdustvis/
+     & 0.210000E-06,0.414800E-05/
+      data epdustvis/2.5,2.5/
+      data omegdustvis/0.92,0.92/
+      data gdustvis/0.55,0.55/
+      data longdustir/
+     & 0.556000E-05,0.625000E-05,0.714000E-05,0.725000E-05,0.735000E-05
+     &,0.746000E-05,0.758000E-05,0.769000E-05,0.781000E-05,0.794000E-05
+     &,0.800000E-05,0.807000E-05,0.813000E-05,0.820000E-05,0.826000E-05
+     &,0.833000E-05,0.840000E-05,0.848000E-05,0.855000E-05,0.862000E-05
+     &,0.870000E-05,0.877000E-05,0.880000E-05,0.884956E-05,0.892857E-05
+     &,0.900901E-05,0.909091E-05,0.917431E-05,0.925926E-05,0.934579E-05
+     &,0.943396E-05,0.952381E-05,0.961539E-05,0.970874E-05,0.980392E-05
+     &,0.990099E-05,0.100000E-04,0.101010E-04,0.102041E-04,0.103093E-04
+     &,0.104167E-04,0.105263E-04,0.106383E-04,0.107527E-04,0.108696E-04
+     &,0.109890E-04,0.111111E-04,0.112360E-04,0.113636E-04,0.114942E-04
+     &,0.116279E-04,0.117647E-04,0.119048E-04,0.120482E-04,0.121951E-04
+     &,0.123457E-04,0.125000E-04,0.126582E-04,0.128205E-04,0.129870E-04
+     &,0.131579E-04,0.133333E-04,0.135135E-04,0.136986E-04,0.138889E-04
+     &,0.140845E-04,0.142857E-04,0.144928E-04,0.147059E-04,0.149254E-04
+     &,0.151515E-04,0.153846E-04,0.156250E-04,0.158730E-04,0.161290E-04
+     &,0.163934E-04,0.166667E-04,0.169492E-04,0.172414E-04,0.175439E-04
+     &,0.178571E-04,0.181818E-04,0.185185E-04,0.188679E-04,0.192308E-04
+     &,0.196078E-04,0.200000E-04,0.204082E-04,0.208333E-04,0.212766E-04
+     &,0.217391E-04,0.222222E-04,0.227273E-04,0.232558E-04,0.238095E-04
+     &,0.243902E-04,0.250000E-04,0.256410E-04,0.263158E-04,0.270270E-04
+     &,0.277778E-04,0.285714E-04,0.294118E-04,0.303030E-04,0.312500E-04
+     &,0.322581E-04,0.333333E-04,0.344828E-04,0.357143E-04,0.370370E-04
+     &,0.384615E-04,0.400000E-04,0.500000E-04,0.600000E-04,0.700000E-04
+     &,0.800000E-04,0.100000E-03,0.120000E-03,0.140000E-03,0.170000E-03
+     &,0.200000E-03,0.230000E-03,0.260000E-03,0.300000E-03/
+      data epdustir/
+     & 1.8223799,1.3646801,0.6918110,0.6400360,0.6000190
+     &,0.5436750,0.5075750,0.5349990,0.5741300,0.6528150
+     &,0.7026240,0.8045070,0.9152510,0.9964510,1.1199900
+     &,1.2508200,1.4647000,1.6723000,1.7668300,1.8770100
+     &,2.0622301,2.2681601,2.3134601,2.3844199,2.4568000
+     &,2.4623699,2.5139699,2.7634001,3.1062000,3.2699001
+     &,3.0982399,2.8657801,2.7559099,2.6911600,2.6657801
+     &,2.6558800,2.6744900,2.6645300,2.6016099,2.5456300
+     &,2.4316900,2.3356500,2.2314799,2.1130800,2.0792401
+     &,2.0617199,2.0427401,1.9252200,1.9074700,1.9007500
+     &,1.7614900,1.5749300,1.5687200,1.5357200,1.3301001
+     &,1.1643699,1.0552500,1.3750900,1.3406500,1.4579200
+     &,1.2703400,1.2499200,0.9752970,1.0887500,1.0551100
+     &,0.8680390,0.9080590,0.9270510,0.8930280,0.7252980
+     &,0.7761930,0.7722600,0.6197060,0.8046810,0.9906260
+     &,1.1675600,1.3232200,1.4563700,1.5742900,1.6683700
+     &,1.6386300,1.6082799,1.5773100,1.5452300,1.5131000
+     &,1.4803500,1.4470100,1.4130900,1.3785900,1.3430200
+     &,1.3074800,1.2714100,1.2348300,1.1977800,1.1602700
+     &,1.1218801,1.0836500,1.0450701,1.0062100,0.9670900
+     &,0.9273350,0.8879470,0.8485210,0.8090940,0.7697440
+     &,0.7305380,0.6912350,0.6527100,0.6146080,0.5770320
+     &,0.5400900,0.5038810,0.3378440,0.2453480,0.1899010
+     &,0.1543380,0.1124400,0.0889283,0.0739620,0.0593130
+     &,0.0496814,0.0428006,0.0376627,0.0324836/
+      data omegdustir/
+     & 0.9455460,0.9255780,0.6110340,0.5893190,0.4896250
+     &,0.3736060,0.2719810,0.1933450,0.1591350,0.1584020
+     &,0.1842620,0.2511510,0.2616600,0.2910640,0.3243100
+     &,0.3532210,0.3744530,0.3675350,0.3614250,0.3678870
+     &,0.3820890,0.3866010,0.3842250,0.3821830,0.3814160
+     &,0.3779760,0.3837150,0.4103900,0.4473680,0.4952290
+     &,0.5245740,0.5125160,0.4980300,0.4833010,0.4788940
+     &,0.4769360,0.4898900,0.5542500,0.5697640,0.6304710
+     &,0.6634610,0.6500820,0.6469200,0.6292330,0.5847980
+     &,0.5847600,0.6166800,0.6622360,0.6334560,0.6793890
+     &,0.7708860,0.7351760,0.6715080,0.7118780,0.8014710
+     &,0.7203560,0.5123400,0.4070190,0.4575710,0.4804760
+     &,0.5493510,0.5477680,0.5564710,0.5089200,0.5221230
+     &,0.5291490,0.4292840,0.4024670,0.4110070,0.3907940
+     &,0.3085770,0.2905000,0.2411480,0.3065880,0.3493080
+     &,0.3836540,0.4065040,0.4211960,0.4325340,0.4396850
+     &,0.4379220,0.4360720,0.4341270,0.4320340,0.4298880
+     &,0.4276300,0.4252520,0.4227480,0.4201070,0.4172670
+     &,0.4143320,0.4112310,0.4079530,0.4044860,0.4008160
+     &,0.3968690,0.3927530,0.3883870,0.3837510,0.3788250
+     &,0.3735170,0.3679440,0.3620120,0.3556900,0.3489460
+     &,0.3417450,0.3339700,0.3257680,0.3170010,0.3076270
+     &,0.2976060,0.2868930,0.2218360,0.1676840,0.1255320
+     &,0.0942349,0.0544707,0.0330144,0.0214071,0.0119898
+     &,0.0073572,0.0047672,0.0033577,0.0022074/
+      data gdustir/
+     & 0.7727880,0.7891680,0.8149010,0.8143680,0.8141810
+     &,0.8135650,0.8105500,0.8033680,0.7936510,0.7786140
+     &,0.7633720,0.7376310,0.7232250,0.7045770,0.6794170
+     &,0.6532190,0.6216970,0.6061300,0.6006830,0.5882300
+     &,0.5672470,0.5528980,0.5515480,0.5486130,0.5436640
+     &,0.5431460,0.5333350,0.5041380,0.4678710,0.4283810
+     &,0.4064880,0.4156190,0.4282650,0.4454850,0.4535160
+     &,0.4693080,0.4752720,0.4885620,0.5029940,0.5025310
+     &,0.5189140,0.5377080,0.5533670,0.5710530,0.5778970
+     &,0.5762890,0.5706920,0.5760510,0.5783530,0.5683710
+     &,0.5678870,0.5920300,0.5962880,0.5909690,0.5981750
+     &,0.6187920,0.6339570,0.6020770,0.6024800,0.5877340
+     &,0.5985190,0.5957170,0.6125820,0.6001100,0.5978010
+     &,0.6065740,0.5983230,0.5910160,0.5887040,0.5944530
+     &,0.5810070,0.5743440,0.5758550,0.5615340,0.5437820
+     &,0.5243770,0.5039760,0.4829940,0.4609260,0.4389000
+     &,0.4355460,0.4321260,0.4286380,0.4247460,0.4211400
+     &,0.4174550,0.4136880,0.4098350,0.4058920,0.4015100
+     &,0.3974090,0.3932030,0.3888870,0.3844560,0.3799040
+     &,0.3748690,0.3700950,0.3651760,0.3601050,0.3548730
+     &,0.3490900,0.3435280,0.3377980,0.3318590,0.3256990
+     &,0.3192870,0.3122380,0.3053810,0.2982310,0.2907650
+     &,0.2829610,0.2747820,0.2274640,0.1885150,0.1562300
+     &,0.1306820,0.0917524,0.0638560,0.0486232,0.0311882
+     &,0.0219897,0.0157278,0.0129793,0.0101294/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.clan91
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.clan91	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.clan91	(revision 57)
@@ -0,0 +1,135 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerdust.h'
+c Spectral  Radiative properties of the Martian dust
+c SPECIAL "bright dust" (Clancy and Lee, 1991)
+
+
+c visible (Clancy and Lee, 1991)
+      integer ndustvis
+      parameter(ndustvis=2)
+      REAL longdustvis(ndustvis),epdustvis(ndustvis)
+     &    ,omegdustvis(ndustvis),gdustvis(ndustvis)
+
+
+c IR (composite: Toon 1977 (5-15micrometers) + Forget, 1996 (>15micrometers) 
+      integer ndustir
+      parameter(ndustir=124)
+      REAL longdustir(ndustir),epdustir(ndustir)
+     &    ,omegdustir(ndustir),gdustir(ndustir)
+
+c Ratio solsir = Tau(vis) / Tau (9 microns)
+      REAL solsir
+      PARAMETER (solsir=2.E+0)
+
+c-----------------------------------------------------------------------
+       
+
+      data longdustvis/
+     & 0.210000E-06,0.414800E-05/
+      data epdustvis/2.5,2.5/
+      data omegdustvis/0.92,0.92/
+      data gdustvis/0.55,0.55/
+      data longdustir/
+     & 0.556000E-05,0.625000E-05,0.714000E-05,0.725000E-05,0.735000E-05
+     &,0.746000E-05,0.758000E-05,0.769000E-05,0.781000E-05,0.794000E-05
+     &,0.800000E-05,0.807000E-05,0.813000E-05,0.820000E-05,0.826000E-05
+     &,0.833000E-05,0.840000E-05,0.848000E-05,0.855000E-05,0.862000E-05
+     &,0.870000E-05,0.877000E-05,0.880000E-05,0.884956E-05,0.892857E-05
+     &,0.900901E-05,0.909091E-05,0.917431E-05,0.925926E-05,0.934579E-05
+     &,0.943396E-05,0.952381E-05,0.961539E-05,0.970874E-05,0.980392E-05
+     &,0.990099E-05,0.100000E-04,0.101010E-04,0.102041E-04,0.103093E-04
+     &,0.104167E-04,0.105263E-04,0.106383E-04,0.107527E-04,0.108696E-04
+     &,0.109890E-04,0.111111E-04,0.112360E-04,0.113636E-04,0.114942E-04
+     &,0.116279E-04,0.117647E-04,0.119048E-04,0.120482E-04,0.121951E-04
+     &,0.123457E-04,0.125000E-04,0.126582E-04,0.128205E-04,0.129870E-04
+     &,0.131579E-04,0.133333E-04,0.135135E-04,0.136986E-04,0.138889E-04
+     &,0.140845E-04,0.142857E-04,0.144928E-04,0.147059E-04,0.149254E-04
+     &,0.151515E-04,0.153846E-04,0.156250E-04,0.158730E-04,0.161290E-04
+     &,0.163934E-04,0.166667E-04,0.169492E-04,0.172414E-04,0.175439E-04
+     &,0.178571E-04,0.181818E-04,0.185185E-04,0.188679E-04,0.192308E-04
+     &,0.196078E-04,0.200000E-04,0.204082E-04,0.208333E-04,0.212766E-04
+     &,0.217391E-04,0.222222E-04,0.227273E-04,0.232558E-04,0.238095E-04
+     &,0.243902E-04,0.250000E-04,0.256410E-04,0.263158E-04,0.270270E-04
+     &,0.277778E-04,0.285714E-04,0.294118E-04,0.303030E-04,0.312500E-04
+     &,0.322581E-04,0.333333E-04,0.344828E-04,0.357143E-04,0.370370E-04
+     &,0.384615E-04,0.400000E-04,0.500000E-04,0.600000E-04,0.700000E-04
+     &,0.800000E-04,0.100000E-03,0.120000E-03,0.140000E-03,0.170000E-03
+     &,0.200000E-03,0.230000E-03,0.260000E-03,0.300000E-03/
+      data epdustir/
+     & 1.8223799,1.3646801,0.6918110,0.6400360,0.6000190
+     &,0.5436750,0.5075750,0.5349990,0.5741300,0.6528150
+     &,0.7026240,0.8045070,0.9152510,0.9964510,1.1199900
+     &,1.2508200,1.4647000,1.6723000,1.7668300,1.8770100
+     &,2.0622301,2.2681601,2.3134601,2.3844199,2.4568000
+     &,2.4623699,2.5139699,2.7634001,3.1062000,3.2699001
+     &,3.0982399,2.8657801,2.7559099,2.6911600,2.6657801
+     &,2.6558800,2.6744900,2.6645300,2.6016099,2.5456300
+     &,2.4316900,2.3356500,2.2314799,2.1130800,2.0792401
+     &,2.0617199,2.0427401,1.9252200,1.9074700,1.9007500
+     &,1.7614900,1.5749300,1.5687200,1.5357200,1.3301001
+     &,1.1643699,1.0552500,1.3750900,1.3406500,1.4579200
+     &,1.2703400,1.2499200,0.9752970,1.0887500,1.0551100
+     &,0.8680390,0.9080590,0.9270510,0.8930280,0.7252980
+     &,0.7761930,0.7722600,0.6197060,0.8046810,0.9906260
+     &,1.1675600,1.3232200,1.4563700,1.5742900,1.6683700
+     &,1.6386300,1.6082799,1.5773100,1.5452300,1.5131000
+     &,1.4803500,1.4470100,1.4130900,1.3785900,1.3430200
+     &,1.3074800,1.2714100,1.2348300,1.1977800,1.1602700
+     &,1.1218801,1.0836500,1.0450701,1.0062100,0.9670900
+     &,0.9273350,0.8879470,0.8485210,0.8090940,0.7697440
+     &,0.7305380,0.6912350,0.6527100,0.6146080,0.5770320
+     &,0.5400900,0.5038810,0.3378440,0.2453480,0.1899010
+     &,0.1543380,0.1124400,0.0889283,0.0739620,0.0593130
+     &,0.0496814,0.0428006,0.0376627,0.0324836/
+      data omegdustir/
+     & 0.9455460,0.9255780,0.6110340,0.5893190,0.4896250
+     &,0.3736060,0.2719810,0.1933450,0.1591350,0.1584020
+     &,0.1842620,0.2511510,0.2616600,0.2910640,0.3243100
+     &,0.3532210,0.3744530,0.3675350,0.3614250,0.3678870
+     &,0.3820890,0.3866010,0.3842250,0.3821830,0.3814160
+     &,0.3779760,0.3837150,0.4103900,0.4473680,0.4952290
+     &,0.5245740,0.5125160,0.4980300,0.4833010,0.4788940
+     &,0.4769360,0.4898900,0.5542500,0.5697640,0.6304710
+     &,0.6634610,0.6500820,0.6469200,0.6292330,0.5847980
+     &,0.5847600,0.6166800,0.6622360,0.6334560,0.6793890
+     &,0.7708860,0.7351760,0.6715080,0.7118780,0.8014710
+     &,0.7203560,0.5123400,0.4070190,0.4575710,0.4804760
+     &,0.5493510,0.5477680,0.5564710,0.5089200,0.5221230
+     &,0.5291490,0.4292840,0.4024670,0.4110070,0.3907940
+     &,0.3085770,0.2905000,0.2411480,0.3065880,0.3493080
+     &,0.3836540,0.4065040,0.4211960,0.4325340,0.4396850
+     &,0.4379220,0.4360720,0.4341270,0.4320340,0.4298880
+     &,0.4276300,0.4252520,0.4227480,0.4201070,0.4172670
+     &,0.4143320,0.4112310,0.4079530,0.4044860,0.4008160
+     &,0.3968690,0.3927530,0.3883870,0.3837510,0.3788250
+     &,0.3735170,0.3679440,0.3620120,0.3556900,0.3489460
+     &,0.3417450,0.3339700,0.3257680,0.3170010,0.3076270
+     &,0.2976060,0.2868930,0.2218360,0.1676840,0.1255320
+     &,0.0942349,0.0544707,0.0330144,0.0214071,0.0119898
+     &,0.0073572,0.0047672,0.0033577,0.0022074/
+      data gdustir/
+     & 0.7727880,0.7891680,0.8149010,0.8143680,0.8141810
+     &,0.8135650,0.8105500,0.8033680,0.7936510,0.7786140
+     &,0.7633720,0.7376310,0.7232250,0.7045770,0.6794170
+     &,0.6532190,0.6216970,0.6061300,0.6006830,0.5882300
+     &,0.5672470,0.5528980,0.5515480,0.5486130,0.5436640
+     &,0.5431460,0.5333350,0.5041380,0.4678710,0.4283810
+     &,0.4064880,0.4156190,0.4282650,0.4454850,0.4535160
+     &,0.4693080,0.4752720,0.4885620,0.5029940,0.5025310
+     &,0.5189140,0.5377080,0.5533670,0.5710530,0.5778970
+     &,0.5762890,0.5706920,0.5760510,0.5783530,0.5683710
+     &,0.5678870,0.5920300,0.5962880,0.5909690,0.5981750
+     &,0.6187920,0.6339570,0.6020770,0.6024800,0.5877340
+     &,0.5985190,0.5957170,0.6125820,0.6001100,0.5978010
+     &,0.6065740,0.5983230,0.5910160,0.5887040,0.5944530
+     &,0.5810070,0.5743440,0.5758550,0.5615340,0.5437820
+     &,0.5243770,0.5039760,0.4829940,0.4609260,0.4389000
+     &,0.4355460,0.4321260,0.4286380,0.4247460,0.4211400
+     &,0.4174550,0.4136880,0.4098350,0.4058920,0.4015100
+     &,0.3974090,0.3932030,0.3888870,0.3844560,0.3799040
+     &,0.3748690,0.3700950,0.3651760,0.3601050,0.3548730
+     &,0.3490900,0.3435280,0.3377980,0.3318590,0.3256990
+     &,0.3192870,0.3122380,0.3053810,0.2982310,0.2907650
+     &,0.2829610,0.2747820,0.2274640,0.1885150,0.1562300
+     &,0.1306820,0.0917524,0.0638560,0.0486232,0.0311882
+     &,0.0219897,0.0157278,0.0129793,0.0101294/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.ocke97
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.ocke97	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerdust.h.ocke97	(revision 57)
@@ -0,0 +1,151 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerdata.h'
+c Spectral  Radiative properties of the Martian dust
+
+c visible (composite; Ockert-Bell, 1996)
+      integer ndatavis
+      parameter(ndatavis=22)
+      REAL longdatavis(ndatavis),epdatavis(ndatavis)
+     &    ,omegdatavis(ndatavis),gdatavis(ndatavis)
+
+
+c IR (composite: Toon 1977 (5-15micrometers) + Forget, 1996 (>15micrometers) 
+      integer ndatair
+      parameter(ndatair=124)
+      REAL longdatair(ndatair),epdatair(ndatair)
+     &    ,omegdatair(ndatair),gdatair(ndatair)
+
+c Ratio solsir = Tau(vis) / Tau (9 microns)
+      REAL solsir
+      PARAMETER (solsir=2.E+0)
+
+c-----------------------------------------------------------------------
+       
+      data longdatavis/
+     & 0.210000E-06,0.300000E-06,0.350000E-06,0.396000E-06,0.500000E-06
+     &,0.596000E-06,0.670000E-06,0.700000E-06,0.802000E-06,0.101500E-05
+     &,0.121000E-05,0.138800E-05,0.219600E-05,0.249000E-05,0.289800E-05
+     &,0.300000E-05,0.319300E-05,0.339600E-05,0.360400E-05,0.377600E-05
+     &,0.398000E-05,0.414800E-05/
+      data epdatavis/
+     & 2.6279900,2.5766001,2.5974200,2.6333699,2.8306701
+     &,2.9744799,3.0389600,3.0630300,3.1325400,3.2430501
+     &,3.3174801,3.3595500,3.2457900,3.1078401,2.7780800
+     &,2.7713201,2.7360499,2.6556201,2.5405700,2.4204800
+     &,2.2459800,1.9280800/
+      data omegdatavis/
+     & 0.7495430,0.6030650,0.5962170,0.6119930,0.7942140
+     &,0.9040160,0.9288640,0.9370630,0.9486390,0.9521170
+     &,0.9540560,0.9558040,0.9550000,0.9511820,0.8042000
+     &,0.8244980,0.8807870,0.9260230,0.9545540,0.9594400
+     &,0.9581870,0.8693700/
+      data gdatavis/
+     & 0.7858040,0.8816350,0.8781190,0.8550090,0.7232660
+     &,0.6684300,0.6547490,0.6502400,0.6412210,0.6326590
+     &,0.6283010,0.6261290,0.6281390,0.6306530,0.6707820
+     &,0.6652110,0.6506370,0.6400950,0.6341580,0.6334550
+     &,0.6341640,0.6506680/
+      data longdatair/
+     & 0.556000E-05,0.625000E-05,0.714000E-05,0.725000E-05,0.735000E-05
+     &,0.746000E-05,0.758000E-05,0.769000E-05,0.781000E-05,0.794000E-05
+     &,0.800000E-05,0.807000E-05,0.813000E-05,0.820000E-05,0.826000E-05
+     &,0.833000E-05,0.840000E-05,0.848000E-05,0.855000E-05,0.862000E-05
+     &,0.870000E-05,0.877000E-05,0.880000E-05,0.884956E-05,0.892857E-05
+     &,0.900901E-05,0.909091E-05,0.917431E-05,0.925926E-05,0.934579E-05
+     &,0.943396E-05,0.952381E-05,0.961539E-05,0.970874E-05,0.980392E-05
+     &,0.990099E-05,0.100000E-04,0.101010E-04,0.102041E-04,0.103093E-04
+     &,0.104167E-04,0.105263E-04,0.106383E-04,0.107527E-04,0.108696E-04
+     &,0.109890E-04,0.111111E-04,0.112360E-04,0.113636E-04,0.114942E-04
+     &,0.116279E-04,0.117647E-04,0.119048E-04,0.120482E-04,0.121951E-04
+     &,0.123457E-04,0.125000E-04,0.126582E-04,0.128205E-04,0.129870E-04
+     &,0.131579E-04,0.133333E-04,0.135135E-04,0.136986E-04,0.138889E-04
+     &,0.140845E-04,0.142857E-04,0.144928E-04,0.147059E-04,0.149254E-04
+     &,0.151515E-04,0.153846E-04,0.156250E-04,0.158730E-04,0.161290E-04
+     &,0.163934E-04,0.166667E-04,0.169492E-04,0.172414E-04,0.175439E-04
+     &,0.178571E-04,0.181818E-04,0.185185E-04,0.188679E-04,0.192308E-04
+     &,0.196078E-04,0.200000E-04,0.204082E-04,0.208333E-04,0.212766E-04
+     &,0.217391E-04,0.222222E-04,0.227273E-04,0.232558E-04,0.238095E-04
+     &,0.243902E-04,0.250000E-04,0.256410E-04,0.263158E-04,0.270270E-04
+     &,0.277778E-04,0.285714E-04,0.294118E-04,0.303030E-04,0.312500E-04
+     &,0.322581E-04,0.333333E-04,0.344828E-04,0.357143E-04,0.370370E-04
+     &,0.384615E-04,0.400000E-04,0.500000E-04,0.600000E-04,0.700000E-04
+     &,0.800000E-04,0.100000E-03,0.120000E-03,0.140000E-03,0.170000E-03
+     &,0.200000E-03,0.230000E-03,0.260000E-03,0.300000E-03/
+      data epdatair/
+     & 1.8223799,1.3646801,0.6918110,0.6400360,0.6000190
+     &,0.5436750,0.5075750,0.5349990,0.5741300,0.6528150
+     &,0.7026240,0.8045070,0.9152510,0.9964510,1.1199900
+     &,1.2508200,1.4647000,1.6723000,1.7668300,1.8770100
+     &,2.0622301,2.2681601,2.3134601,2.3844199,2.4568000
+     &,2.4623699,2.5139699,2.7634001,3.1062000,3.2699001
+     &,3.0982399,2.8657801,2.7559099,2.6911600,2.6657801
+     &,2.6558800,2.6744900,2.6645300,2.6016099,2.5456300
+     &,2.4316900,2.3356500,2.2314799,2.1130800,2.0792401
+     &,2.0617199,2.0427401,1.9252200,1.9074700,1.9007500
+     &,1.7614900,1.5749300,1.5687200,1.5357200,1.3301001
+     &,1.1643699,1.0552500,1.3750900,1.3406500,1.4579200
+     &,1.2703400,1.2499200,0.9752970,1.0887500,1.0551100
+     &,0.8680390,0.9080590,0.9270510,0.8930280,0.7252980
+     &,0.7761930,0.7722600,0.6197060,0.8046810,0.9906260
+     &,1.1675600,1.3232200,1.4563700,1.5742900,1.6683700
+     &,1.6386300,1.6082799,1.5773100,1.5452300,1.5131000
+     &,1.4803500,1.4470100,1.4130900,1.3785900,1.3430200
+     &,1.3074800,1.2714100,1.2348300,1.1977800,1.1602700
+     &,1.1218801,1.0836500,1.0450701,1.0062100,0.9670900
+     &,0.9273350,0.8879470,0.8485210,0.8090940,0.7697440
+     &,0.7305380,0.6912350,0.6527100,0.6146080,0.5770320
+     &,0.5400900,0.5038810,0.3378440,0.2453480,0.1899010
+     &,0.1543380,0.1124400,0.0889283,0.0739620,0.0593130
+     &,0.0496814,0.0428006,0.0376627,0.0324836/
+      data omegdatair/
+     & 0.9455460,0.9255780,0.6110340,0.5893190,0.4896250
+     &,0.3736060,0.2719810,0.1933450,0.1591350,0.1584020
+     &,0.1842620,0.2511510,0.2616600,0.2910640,0.3243100
+     &,0.3532210,0.3744530,0.3675350,0.3614250,0.3678870
+     &,0.3820890,0.3866010,0.3842250,0.3821830,0.3814160
+     &,0.3779760,0.3837150,0.4103900,0.4473680,0.4952290
+     &,0.5245740,0.5125160,0.4980300,0.4833010,0.4788940
+     &,0.4769360,0.4898900,0.5542500,0.5697640,0.6304710
+     &,0.6634610,0.6500820,0.6469200,0.6292330,0.5847980
+     &,0.5847600,0.6166800,0.6622360,0.6334560,0.6793890
+     &,0.7708860,0.7351760,0.6715080,0.7118780,0.8014710
+     &,0.7203560,0.5123400,0.4070190,0.4575710,0.4804760
+     &,0.5493510,0.5477680,0.5564710,0.5089200,0.5221230
+     &,0.5291490,0.4292840,0.4024670,0.4110070,0.3907940
+     &,0.3085770,0.2905000,0.2411480,0.3065880,0.3493080
+     &,0.3836540,0.4065040,0.4211960,0.4325340,0.4396850
+     &,0.4379220,0.4360720,0.4341270,0.4320340,0.4298880
+     &,0.4276300,0.4252520,0.4227480,0.4201070,0.4172670
+     &,0.4143320,0.4112310,0.4079530,0.4044860,0.4008160
+     &,0.3968690,0.3927530,0.3883870,0.3837510,0.3788250
+     &,0.3735170,0.3679440,0.3620120,0.3556900,0.3489460
+     &,0.3417450,0.3339700,0.3257680,0.3170010,0.3076270
+     &,0.2976060,0.2868930,0.2218360,0.1676840,0.1255320
+     &,0.0942349,0.0544707,0.0330144,0.0214071,0.0119898
+     &,0.0073572,0.0047672,0.0033577,0.0022074/
+      data gdatair/
+     & 0.7727880,0.7891680,0.8149010,0.8143680,0.8141810
+     &,0.8135650,0.8105500,0.8033680,0.7936510,0.7786140
+     &,0.7633720,0.7376310,0.7232250,0.7045770,0.6794170
+     &,0.6532190,0.6216970,0.6061300,0.6006830,0.5882300
+     &,0.5672470,0.5528980,0.5515480,0.5486130,0.5436640
+     &,0.5431460,0.5333350,0.5041380,0.4678710,0.4283810
+     &,0.4064880,0.4156190,0.4282650,0.4454850,0.4535160
+     &,0.4693080,0.4752720,0.4885620,0.5029940,0.5025310
+     &,0.5189140,0.5377080,0.5533670,0.5710530,0.5778970
+     &,0.5762890,0.5706920,0.5760510,0.5783530,0.5683710
+     &,0.5678870,0.5920300,0.5962880,0.5909690,0.5981750
+     &,0.6187920,0.6339570,0.6020770,0.6024800,0.5877340
+     &,0.5985190,0.5957170,0.6125820,0.6001100,0.5978010
+     &,0.6065740,0.5983230,0.5910160,0.5887040,0.5944530
+     &,0.5810070,0.5743440,0.5758550,0.5615340,0.5437820
+     &,0.5243770,0.5039760,0.4829940,0.4609260,0.4389000
+     &,0.4355460,0.4321260,0.4286380,0.4247460,0.4211400
+     &,0.4174550,0.4136880,0.4098350,0.4058920,0.4015100
+     &,0.3974090,0.3932030,0.3888870,0.3844560,0.3799040
+     &,0.3748690,0.3700950,0.3651760,0.3601050,0.3548730
+     &,0.3490900,0.3435280,0.3377980,0.3318590,0.3256990
+     &,0.3192870,0.3122380,0.3053810,0.2982310,0.2907650
+     &,0.2829610,0.2747820,0.2274640,0.1885150,0.1562300
+     &,0.1306820,0.0917524,0.0638560,0.0486232,0.0311882
+     &,0.0219897,0.0157278,0.0129793,0.0101294/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=2.5E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=3.e-6,qrefice=2.2)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0594757,2.0556829,2.2896707,2.3257456,2.5099661,
+     &2.9161227,2.8020720,0.9336269,1.5134708,1.6889371,
+     &1.8322314,1.9146321,1.9831489,2.0514481,2.1239402,
+     &2.1971617,2.2737679,2.3492715,2.4073563,2.4458375,
+     &2.4726937,2.4971056,2.5221505,2.5486584,2.5773935,
+     &2.6081295,2.6391418,2.6699214,2.7093878,2.7364888,
+     &2.7674158,2.8051183,2.8506889,2.9136717,2.9810331,
+     &3.0470915,3.0933173,3.1121876,3.1349294,3.1638598,
+     &3.1912117,3.2744172,3.2761116,3.2431061,3.2102768,
+     &3.1776469,3.0866187,2.9577594,2.8526461,2.8176398,
+     &2.7821639,2.7549253,2.7503767,2.7499533,2.7608297,
+     &2.7274404,2.5991304,2.5173609/
+       data epiceir/
+     &2.4190733,2.3199425,2.2540693,2.1095867,1.9555371,
+     &1.8269345,1.8036077,1.7855358,1.7711544,1.7690116,
+     &1.7829260,1.8295234,1.8549844,1.8687238,1.8656639,
+     &1.8619236,1.8579320,1.8448261,1.8235378,1.8017112,
+     &1.7578924,1.7259388,1.7054915,1.6687690,1.6185619,
+     &1.5858195,1.5535859,1.5112923,1.4703351,1.4347173,
+     &1.4047177,1.3697965,1.3251381,1.2680571,1.1960392,
+     &1.1172380,1.0578237,0.9745934,0.8949080,0.8474779,
+     &0.7968613,0.7102672,0.6077121,0.5407101,0.5224510,
+     &0.5266400,0.5439359,0.5927324,0.6681964,0.7765685,
+     &0.8902640,1.0280455,1.1302272,1.3228931,1.4579507,
+     &1.5726897,1.6591437,1.7202030,1.7452124,1.7473249,
+     &1.7453249,1.7290004,1.7075497,1.6815135,1.6501899,
+     &1.6082871,1.5523466,1.4047438,1.2489705,1.1717392,
+     &1.1052268,0.9884429,0.9432285,0.9081387,0.8657278,
+     &0.8152991,0.6394543,0.5499370,0.5321090,0.5103995,
+     &0.4716277,0.4179623,0.3657534,0.2508311,0.2299716,
+     &0.2108125,0.1924924,0.1673682,0.1598235,0.1464571,
+     &0.1420538,0.1533015,0.1798090,0.2135266,0.2636204,
+     &0.3173732,0.3756316,0.4310254,0.4916850,0.5594596,
+     &0.6165060,0.6480070,0.6899570,0.7094871,0.6969641,
+     &0.6295437,0.5589720,0.4951279,0.4591832,0.4279796,
+     &0.3880569,0.3635468,0.3400364,0.2975883,0.2645470,
+     &0.2365445,0.2152134,0.2020684,0.2264057,0.2488454,
+     &0.2725164,0.3044016,0.3105968,0.3001241,0.2917667,
+     &0.2818419,0.2701418,0.2540473,0.2319813,0.2079458,
+     &0.1858774,0.1567208,0.1371507,0.1266034,0.0947660,
+     &0.0791723,0.0730714,0.0680956,0.0596443,0.0523504,
+     &0.0464472,0.0328870,0.0206243,0.0157984/
+       data omegicevis/
+     &0.5478598,0.9999998,0.9999930,0.9999391,0.9852892,
+     &0.9747255,0.9896471,0.3921073,0.3646954,0.3975615,
+     &0.4174147,0.4264744,0.4352827,0.4448440,0.4550543,
+     &0.4644430,0.4733422,0.4809923,0.4836857,0.4835298,
+     &0.4823884,0.4821825,0.4822653,0.4822173,0.4828566,
+     &0.4861327,0.4930841,0.5041330,0.5267492,0.5471958,
+     &0.5780509,0.6176673,0.6584746,0.7053177,0.7443977,
+     &0.7823801,0.8173603,0.8434741,0.8708835,0.8929197,
+     &0.9106523,0.9344197,0.9465593,0.9499664,0.9501572,
+     &0.9384264,0.9281004,0.9095014,0.8796501,0.8642664,
+     &0.8496780,0.8360837,0.8353950,0.8325557,0.8399941,
+     &0.8961539,0.9191431,0.9229702/
+       data omegiceir/
+     &0.9181703,0.9106198,0.9053057,0.8796571,0.8349904,
+     &0.7679166,0.7511637,0.7306502,0.7113808,0.6862068,
+     &0.6691588,0.6380840,0.6405194,0.6548850,0.6619208,
+     &0.6655905,0.6727100,0.6823230,0.6875201,0.6890487,
+     &0.6883412,0.6776634,0.6725497,0.6736822,0.6769779,
+     &0.6740052,0.6752223,0.6791695,0.6745857,0.6706817,
+     &0.6675888,0.6726563,0.6810013,0.6928600,0.7032822,
+     &0.7016219,0.6788723,0.6561857,0.6251051,0.5999153,
+     &0.5784231,0.5407491,0.4858367,0.4156316,0.3081297,
+     &0.2542117,0.2051306,0.1674406,0.1491730,0.1494159,
+     &0.1588227,0.1749455,0.1886469,0.2149218,0.2356885,
+     &0.2543647,0.2729447,0.2907736,0.3091933,0.3188552,
+     &0.3287012,0.3389443,0.3486176,0.3593718,0.3712797,
+     &0.3844498,0.3992367,0.4283787,0.4480617,0.4557256,
+     &0.4565090,0.4582297,0.4537602,0.4503480,0.4573702,
+     &0.4677775,0.5004078,0.4921789,0.4687816,0.4652704,
+     &0.4829984,0.5146720,0.5423340,0.5802344,0.5751773,
+     &0.5603711,0.5358865,0.4843219,0.4606548,0.3958648,
+     &0.2311990,0.1309277,0.0689810,0.0473044,0.0357645,
+     &0.0302096,0.0285216,0.0283661,0.0288575,0.0298694,
+     &0.0319034,0.0337869,0.0364643,0.0395041,0.0429032,
+     &0.0455614,0.0464966,0.0454506,0.0435048,0.0429859,
+     &0.0433492,0.0439662,0.0451907,0.0472841,0.0479729,
+     &0.0480491,0.0468699,0.0440733,0.0341798,0.0291907,
+     &0.0265080,0.0251720,0.0254859,0.0266501,0.0271129,
+     &0.0276442,0.0282702,0.0292041,0.0302890,0.0310830,
+     &0.0316508,0.0322409,0.0326373,0.0328552,0.0364115,
+     &0.0346299,0.0332475,0.0322650,0.0299256,0.0276080,
+     &0.0250169,0.0166050,0.0108650,0.0093190/
+       data gicevis/
+     &0.9487292,0.8501517,0.8084917,0.8064129,0.7796354,
+     &0.8265753,0.9093526,0.9365674,0.9241107,0.9169607,
+     &0.9102123,0.9061169,0.9015271,0.8957432,0.8886193,
+     &0.8810557,0.8728880,0.8651341,0.8625306,0.8636174,
+     &0.8661903,0.8671943,0.8675743,0.8681570,0.8683062,
+     &0.8662376,0.8610609,0.8520109,0.8346523,0.8228595,
+     &0.8053397,0.7876619,0.7732534,0.7589003,0.7500000,
+     &0.7413471,0.7345427,0.7344642,0.7366309,0.7405840,
+     &0.7467821,0.7644036,0.7784136,0.7846442,0.7965618,
+     &0.8083032,0.8136568,0.8199432,0.8255728,0.8271201,
+     &0.8275242,0.8268972,0.8249819,0.8245324,0.8223208,
+     &0.8117355,0.8062472,0.8041336/
+       data giceir/
+     &0.8028125,0.8016422,0.8009415,0.7998557,0.7981417,
+     &0.7963558,0.7960360,0.7959067,0.7956044,0.7956340,
+     &0.7950525,0.7882976,0.7844244,0.7777230,0.7753325,
+     &0.7731695,0.7707492,0.7681598,0.7659332,0.7639940,
+     &0.7603320,0.7571294,0.7533165,0.7466281,0.7393790,
+     &0.7345678,0.7292926,0.7235673,0.7182128,0.7126561,
+     &0.7069229,0.7005080,0.6936766,0.6865230,0.6792384,
+     &0.6722496,0.6657850,0.6547473,0.6428918,0.6345846,
+     &0.6255974,0.6109424,0.5946515,0.5828903,0.5715944,
+     &0.5652506,0.5587830,0.5527261,0.5470884,0.5424237,
+     &0.5377048,0.5334029,0.5303385,0.5231666,0.5153511,
+     &0.5072109,0.4983860,0.4895755,0.4802338,0.4751357,
+     &0.4699576,0.4646551,0.4586791,0.4522615,0.4457387,
+     &0.4389421,0.4309897,0.4133823,0.3940207,0.3839259,
+     &0.3734751,0.3533985,0.3436313,0.3339687,0.3244507,
+     &0.3145035,0.2824177,0.2612788,0.2519038,0.2428105,
+     &0.2333613,0.2230495,0.2126012,0.1826718,0.1755434,
+     &0.1677177,0.1589084,0.1445894,0.1393903,0.1275548,
+     &0.1034226,0.0862908,0.0732680,0.0678129,0.0630464,
+     &0.0581228,0.0541460,0.0502856,0.0463469,0.0425679,
+     &0.0408138,0.0391414,0.0376537,0.0370017,0.0370768,
+     &0.0378109,0.0381619,0.0376564,0.0360912,0.0348694,
+     &0.0337249,0.0332462,0.0328845,0.0325112,0.0317704,
+     &0.0309227,0.0299524,0.0289665,0.0271364,0.0258780,
+     &0.0250178,0.0241542,0.0240672,0.0236685,0.0231454,
+     &0.0228576,0.0225964,0.0223764,0.0221073,0.0215770,
+     &0.0209200,0.0198007,0.0188984,0.0183424,0.0170089,
+     &0.0154822,0.0146694,0.0140185,0.0127366,0.0115393,
+     &0.0104058,0.0071931,0.0046216,0.0037448/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.005
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.005	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.005	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 0.5 MICRONS (Franck Montmessin) 
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=65.E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=.5e-6,qrefice=2.8)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.1832037,3.0220087,2.4477277,1.7936502,0.7896869,
+     &0.3638896,0.0989704,0.1296485,0.4747359,0.6042269,
+     &0.7391522,0.8270491,0.9101521,1.0053538,1.1204786,
+     &1.2478381,1.3907613,1.5331460,1.5983437,1.5859528,
+     &1.5294470,1.4795980,1.4226713,1.3357474,1.2130061,
+     &1.0765146,0.9549081,0.8522044,0.7333566,0.6579455,
+     &0.5836973,0.5145633,0.4580996,0.4042850,0.3620397,
+     &0.3252469,0.2931417,0.2685316,0.2455204,0.2259372,
+     &0.2092481,0.1779757,0.1460140,0.1362165,0.1238611,
+     &0.1114724,0.1013308,0.0958610,0.0989326,0.1026265,
+     &0.1056360,0.1088488,0.1078976,0.1089309,0.1056082,
+     &0.0775238,0.0604925,0.0548426/
+       data epiceir/
+     &0.0518859,0.0499921,0.0489281,0.0504541,0.0563693,
+     &0.0690525,0.0726885,0.0778081,0.0828819,0.0909149,
+     &0.0975723,0.1109497,0.1108328,0.1043100,0.1007861,
+     &0.0985987,0.0951375,0.0903377,0.0868122,0.0846175,
+     &0.0815860,0.0824196,0.0820647,0.0784795,0.0737793,
+     &0.0722562,0.0696436,0.0659283,0.0645018,0.0631230,
+     &0.0617881,0.0583767,0.0540010,0.0487309,0.0435927,
+     &0.0405531,0.0414796,0.0409568,0.0413717,0.0422409,
+     &0.0421894,0.0416819,0.0412459,0.0438362,0.0547753,
+     &0.0626479,0.0729752,0.0890032,0.1097846,0.1367236,
+     &0.1645632,0.1977923,0.2204414,0.2592581,0.2749909,
+     &0.2818336,0.2731296,0.2562519,0.2294758,0.2146772,
+     &0.2003647,0.1846708,0.1704422,0.1563350,0.1425573,
+     &0.1287259,0.1145926,0.0897004,0.0727098,0.0659172,
+     &0.0615737,0.0541199,0.0521104,0.0503624,0.0466379,
+     &0.0422906,0.0299038,0.0264714,0.0274238,0.0264572,
+     &0.0231405,0.0186739,0.0150726,0.0092988,0.0087124,
+     &0.0084247,0.0083568,0.0085502,0.0087600,0.0096209,
+     &0.0139307,0.0186971,0.0250932,0.0314043,0.0401234,
+     &0.0493907,0.0591965,0.0683152,0.0781187,0.0888679,
+     &0.0974246,0.1010759,0.1059724,0.1067670,0.1021143,
+     &0.0896822,0.0784708,0.0693838,0.0645370,0.0599980,
+     &0.0540903,0.0504870,0.0469609,0.0408812,0.0363856,
+     &0.0326679,0.0299615,0.0284745,0.0328476,0.0366500,
+     &0.0404568,0.0452998,0.0461202,0.0442455,0.0428461,
+     &0.0412572,0.0394165,0.0369267,0.0336194,0.0301124,
+     &0.0269362,0.0227761,0.0199896,0.0184862,0.0138242,
+     &0.0116880,0.0108555,0.0101642,0.0089899,0.0079631,
+     &0.0071303,0.0051857,0.0033162,0.0025556/
+       data omegicevis/
+     &0.5254589,1.0000000,0.9999991,0.9999862,0.9916013,
+     &0.9620332,0.9309642,0.0638710,0.0662553,0.0823147,
+     &0.0963694,0.1048159,0.1133009,0.1232222,0.1352970,
+     &0.1488444,0.1650357,0.1841903,0.2017575,0.2166039,
+     &0.2292029,0.2433622,0.2616843,0.2852339,0.3131889,
+     &0.3412718,0.3660752,0.3928272,0.4309901,0.4492646,
+     &0.4801873,0.5139056,0.5460804,0.5844365,0.6146011,
+     &0.6468718,0.6772872,0.6975922,0.7236167,0.7461668,
+     &0.7655625,0.7888166,0.7862524,0.7823967,0.7588729,
+     &0.6857340,0.6214526,0.5368491,0.4470918,0.4119983,
+     &0.3805366,0.3541514,0.3503601,0.3458159,0.3562116,
+     &0.4411552,0.4703839,0.4680012/
+       data omegiceir/
+     &0.4410178,0.4089485,0.3886294,0.3210695,0.2419387,
+     &0.1693097,0.1560958,0.1421160,0.1303703,0.1174139,
+     &0.1096975,0.0955347,0.0956753,0.0990973,0.1009341,
+     &0.1015035,0.1034342,0.1062110,0.1070629,0.1064178,
+     &0.1036404,0.0972966,0.0935797,0.0912126,0.0893898,
+     &0.0863554,0.0848208,0.0840290,0.0804088,0.0772171,
+     &0.0744647,0.0741630,0.0747523,0.0763844,0.0774963,
+     &0.0745925,0.0657440,0.0572360,0.0481501,0.0421850,
+     &0.0375024,0.0306774,0.0232991,0.0167966,0.0100478,
+     &0.0075047,0.0055527,0.0042542,0.0036752,0.0036866,
+     &0.0039804,0.0045186,0.0049973,0.0059663,0.0067372,
+     &0.0074513,0.0081464,0.0088094,0.0094550,0.0097817,
+     &0.0101162,0.0104466,0.0107313,0.0110585,0.0114425,
+     &0.0118786,0.0123615,0.0132487,0.0135842,0.0136287,
+     &0.0132877,0.0127042,0.0121676,0.0117236,0.0118197,
+     &0.0120773,0.0129020,0.0118840,0.0105257,0.0101722,
+     &0.0107762,0.0121118,0.0133881,0.0149663,0.0144329,
+     &0.0133009,0.0117145,0.0090358,0.0080348,0.0058144,
+     &0.0023043,0.0010388,0.0004725,0.0003068,0.0002241,
+     &0.0001846,0.0001716,0.0001686,0.0001696,0.0001738,
+     &0.0001855,0.0001962,0.0002120,0.0002308,0.0002526,
+     &0.0002702,0.0002761,0.0002683,0.0002543,0.0002499,
+     &0.0002511,0.0002545,0.0002619,0.0002746,0.0002779,
+     &0.0002773,0.0002686,0.0002502,0.0001890,0.0001591,
+     &0.0001434,0.0001354,0.0001372,0.0001437,0.0001462,
+     &0.0001491,0.0001526,0.0001578,0.0001639,0.0001681,
+     &0.0001709,0.0001735,0.0001751,0.0001759,0.0001954,
+     &0.0001839,0.0001755,0.0001695,0.0001556,0.0001422,
+     &0.0001276,0.0000821,0.0000525,0.0000447/
+       data gicevis/
+     &0.9440147,0.7965972,0.8107608,0.7669883,0.6258456,
+     &0.4763368,0.3164644,0.2653029,0.2540545,0.2543145,
+     &0.2552853,0.2555421,0.2551991,0.2546355,0.2543354,
+     &0.2544852,0.2551972,0.2571523,0.2610470,0.2657359,
+     &0.2696103,0.2723087,0.2749877,0.2770225,0.2766140,
+     &0.2729803,0.2674728,0.2618006,0.2547111,0.2485000,
+     &0.2423996,0.2361834,0.2305830,0.2249461,0.2198020,
+     &0.2149920,0.2103154,0.2060570,0.2018775,0.1979253,
+     &0.1941856,0.1853729,0.1727509,0.1681767,0.1610373,
+     &0.1502239,0.1399678,0.1301550,0.1233758,0.1211795,
+     &0.1180928,0.1149843,0.1129097,0.1123236,0.1113603,
+     &0.1042673,0.0958210,0.0918495/
+       data giceir/
+     &0.0879977,0.0844017,0.0822360,0.0778328,0.0732655,
+     &0.0690960,0.0682752,0.0674878,0.0666989,0.0659700,
+     &0.0653013,0.0618198,0.0604822,0.0583973,0.0576873,
+     &0.0569741,0.0562715,0.0555336,0.0547710,0.0540252,
+     &0.0525653,0.0511566,0.0498082,0.0478042,0.0458238,
+     &0.0445190,0.0432495,0.0419659,0.0407013,0.0394739,
+     &0.0382847,0.0371085,0.0359234,0.0347448,0.0335567,
+     &0.0323681,0.0312087,0.0295399,0.0279082,0.0268502,
+     &0.0258095,0.0242507,0.0226832,0.0216094,0.0205569,
+     &0.0199994,0.0194464,0.0189064,0.0183935,0.0179262,
+     &0.0174721,0.0170318,0.0167252,0.0161173,0.0156093,
+     &0.0151735,0.0148010,0.0144899,0.0141909,0.0140236,
+     &0.0138500,0.0136646,0.0134407,0.0131990,0.0129545,
+     &0.0126989,0.0123981,0.0117364,0.0110220,0.0106622,
+     &0.0102900,0.0096114,0.0092885,0.0089773,0.0086913,
+     &0.0084029,0.0075082,0.0069195,0.0066498,0.0064030,
+     &0.0061638,0.0059125,0.0056564,0.0049044,0.0047217,
+     &0.0045194,0.0042905,0.0039171,0.0037807,0.0034683,
+     &0.0028199,0.0023535,0.0019931,0.0018378,0.0017011,
+     &0.0015627,0.0014514,0.0013460,0.0012398,0.0011386,
+     &0.0010917,0.0010505,0.0010140,0.0010014,0.0010106,
+     &0.0010385,0.0010523,0.0010404,0.0009990,0.0009673,
+     &0.0009376,0.0009252,0.0009159,0.0009061,0.0008860,
+     &0.0008628,0.0008361,0.0008086,0.0007567,0.0007210,
+     &0.0006967,0.0006727,0.0006705,0.0006603,0.0006463,
+     &0.0006386,0.0006316,0.0006257,0.0006182,0.0006034,
+     &0.0005850,0.0005536,0.0005284,0.0005128,0.0004754,
+     &0.0004328,0.0004100,0.0003918,0.0003559,0.0003223,
+     &0.0002906,0.0002006,0.0001287,0.0001043/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.01
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.01	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.01	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 1 MICRONS (Franck M ontmessin)
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=23.E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=1.e-6,qrefice=2.75)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.1192634,2.3866904,3.0710473,3.2044775,2.4812233,
+     &1.5408986,0.5308650,0.2823303,0.8151994,0.9982054,
+     &1.1776563,1.2913215,1.3945227,1.5075399,1.6387790,
+     &1.7810757,1.9404513,2.1077142,2.2311430,2.3039091,
+     &2.3424239,2.3839264,2.4322689,2.4745319,2.4916942,
+     &2.4703403,2.4206913,2.3665223,2.2752666,2.1747661,
+     &2.0781898,1.9706942,1.8699772,1.7651500,1.6681471,
+     &1.5780047,1.4902014,1.4125437,1.3384955,1.2692254,
+     &1.2053254,1.0666140,0.9020291,0.8492430,0.7754933,
+     &0.6846126,0.6097632,0.5495253,0.5234407,0.5223706,
+     &0.5196257,0.5199762,0.5163358,0.5186846,0.5133317,
+     &0.4363440,0.3637202,0.3336293/
+       data epiceir/
+     &0.3097547,0.2899992,0.2780589,0.2617716,0.2548404,
+     &0.2650286,0.2694660,0.2773825,0.2855305,0.3007740,
+     &0.3150952,0.3452618,0.3475289,0.3352611,0.3274985,
+     &0.3222899,0.3144871,0.3029351,0.2930705,0.2859025,
+     &0.2744837,0.2721885,0.2687397,0.2570274,0.2420578,
+     &0.2354512,0.2268017,0.2151964,0.2083238,0.2020417,
+     &0.1963370,0.1862280,0.1736113,0.1585643,0.1430934,
+     &0.1316877,0.1294224,0.1228625,0.1185373,0.1171891,
+     &0.1139945,0.1080297,0.1016796,0.1029433,0.1216047,
+     &0.1356978,0.1546041,0.1849135,0.2246722,0.2768484,
+     &0.3310658,0.3965377,0.4426499,0.5253468,0.5668955,
+     &0.5922215,0.5880766,0.5654298,0.5190575,0.4913011,
+     &0.4635427,0.4314885,0.4015174,0.3712321,0.3411348,
+     &0.3102629,0.2780339,0.2194865,0.1779260,0.1610434,
+     &0.1496597,0.1303599,0.1247039,0.1198948,0.1110008,
+     &0.1007371,0.0712706,0.0622413,0.0636172,0.0611146,
+     &0.0536605,0.0437097,0.0355698,0.0220631,0.0205425,
+     &0.0196398,0.0191828,0.0191171,0.0193923,0.0208254,
+     &0.0290338,0.0383325,0.0509648,0.0635566,0.0810146,
+     &0.0995692,0.1192388,0.1375636,0.1572995,0.1789836,
+     &0.1963544,0.2039599,0.2141546,0.2161427,0.2071475,
+     &0.1822319,0.1595332,0.1409966,0.1310656,0.1218277,
+     &0.1098314,0.1025169,0.0953714,0.0830212,0.0738609,
+     &0.0662767,0.0607402,0.0576721,0.0664149,0.0740372,
+     &0.0816919,0.0914682,0.0931417,0.0893927,0.0865822,
+     &0.0833833,0.0796740,0.0746523,0.0679690,0.0608707,
+     &0.0544375,0.0460094,0.0403652,0.0373210,0.0279000,
+     &0.0235664,0.0218776,0.0204772,0.0180988,0.0160214,
+     &0.0143370,0.0104088,0.0066479,0.0051210/
+       data omegicevis/
+     &0.5386420,1.0000000,0.9999983,0.9999850,0.9955066,
+     &0.9844767,0.9774309,0.1614970,0.1627708,0.1939070,
+     &0.2183838,0.2320055,0.2452919,0.2601796,0.2772272,
+     &0.2949594,0.3144796,0.3355922,0.3536791,0.3691771,
+     &0.3833629,0.3993029,0.4197326,0.4469427,0.4815640,
+     &0.5188605,0.5528998,0.5873977,0.6337127,0.6578971,
+     &0.6923810,0.7275212,0.7585961,0.7921193,0.8169167,
+     &0.8410107,0.8620409,0.8756065,0.8913837,0.9042724,
+     &0.9147988,0.9275904,0.9291340,0.9284223,0.9196891,
+     &0.8876197,0.8561562,0.8072060,0.7431433,0.7140535,
+     &0.6865323,0.6620798,0.6595058,0.6550942,0.6665309,
+     &0.7495020,0.7778903,0.7786440/
+       data omegiceir/
+     &0.7604749,0.7366999,0.7205958,0.6580536,0.5668025,
+     &0.4587096,0.4356672,0.4097329,0.3868122,0.3598266,
+     &0.3431242,0.3130278,0.3147338,0.3254214,0.3307036,
+     &0.3329236,0.3383887,0.3458877,0.3488805,0.3483467,
+     &0.3436954,0.3301307,0.3225699,0.3191252,0.3170218,
+     &0.3108034,0.3083988,0.3079879,0.2998554,0.2926259,
+     &0.2863949,0.2870713,0.2903223,0.2965344,0.3012683,
+     &0.2946250,0.2699749,0.2452659,0.2165022,0.1961797,
+     &0.1795562,0.1537112,0.1230571,0.0931165,0.0588126,
+     &0.0449536,0.0339055,0.0263423,0.0229347,0.0230562,
+     &0.0248910,0.0281887,0.0311059,0.0369957,0.0417154,
+     &0.0460758,0.0503238,0.0543560,0.0582899,0.0602842,
+     &0.0623192,0.0643389,0.0661152,0.0681381,0.0704755,
+     &0.0731053,0.0760185,0.0814240,0.0838108,0.0843268,
+     &0.0827206,0.0799519,0.0771474,0.0748236,0.0755603,
+     &0.0772232,0.0825206,0.0770989,0.0693231,0.0673670,
+     &0.0711028,0.0790820,0.0865735,0.0959862,0.0931518,
+     &0.0868936,0.0778482,0.0618916,0.0556907,0.0414274,
+     &0.0172511,0.0079517,0.0036608,0.0023874,0.0017483,
+     &0.0014435,0.0013443,0.0013223,0.0013315,0.0013663,
+     &0.0014583,0.0015426,0.0016673,0.0018146,0.0019850,
+     &0.0021217,0.0021683,0.0021083,0.0019995,0.0019657,
+     &0.0019761,0.0020031,0.0020611,0.0021607,0.0021879,
+     &0.0021838,0.0021172,0.0019728,0.0014927,0.0012580,
+     &0.0011338,0.0010718,0.0010859,0.0011371,0.0011565,
+     &0.0011796,0.0012070,0.0012485,0.0012965,0.0013299,
+     &0.0013524,0.0013734,0.0013868,0.0013938,0.0015480,
+     &0.0014583,0.0013921,0.0013452,0.0012361,0.0011303,
+     &0.0010147,0.0006545,0.0004192,0.0003572/
+       data gicevis/
+     &0.9472355,0.7817819,0.8104869,0.8370932,0.8250610,
+     &0.7729445,0.6907796,0.6560782,0.6408569,0.6389719,
+     &0.6383793,0.6379554,0.6365179,0.6343526,0.6319877,
+     &0.6300194,0.6284310,0.6279051,0.6303032,0.6338103,
+     &0.6368135,0.6378741,0.6381156,0.6375306,0.6352661,
+     &0.6311954,0.6260597,0.6201031,0.6121832,0.6065006,
+     &0.5996023,0.5927197,0.5867192,0.5807193,0.5757619,
+     &0.5710542,0.5665758,0.5626292,0.5584362,0.5544021,
+     &0.5504646,0.5406969,0.5247300,0.5183126,0.5077586,
+     &0.4904415,0.4721469,0.4530136,0.4389606,0.4342998,
+     &0.4274060,0.4202327,0.4151474,0.4137563,0.4111845,
+     &0.3915503,0.3674690,0.3556202/
+       data giceir/
+     &0.3438542,0.3325318,0.3255288,0.3110588,0.2956603,
+     &0.2814386,0.2786329,0.2760077,0.2733599,0.2710718,
+     &0.2689575,0.2567067,0.2516982,0.2434593,0.2405528,
+     &0.2376774,0.2347744,0.2316430,0.2284427,0.2253558,
+     &0.2193370,0.2136727,0.2081797,0.1998119,0.1914108,
+     &0.1859097,0.1804893,0.1749370,0.1695419,0.1642952,
+     &0.1592050,0.1540809,0.1488775,0.1436688,0.1384313,
+     &0.1332790,0.1283971,0.1213205,0.1144493,0.1100211,
+     &0.1056500,0.0991218,0.0926120,0.0882538,0.0841548,
+     &0.0820158,0.0799326,0.0779781,0.0761736,0.0745909,
+     &0.0730158,0.0714981,0.0703739,0.0679849,0.0657191,
+     &0.0636815,0.0617775,0.0601208,0.0585010,0.0576308,
+     &0.0567537,0.0558357,0.0547788,0.0536580,0.0525378,
+     &0.0513812,0.0500444,0.0471741,0.0441685,0.0426759,
+     &0.0411515,0.0383862,0.0370815,0.0358252,0.0346632,
+     &0.0334926,0.0298874,0.0275405,0.0264717,0.0254866,
+     &0.0245280,0.0235218,0.0225007,0.0195162,0.0187928,
+     &0.0179918,0.0170857,0.0156065,0.0150664,0.0138279,
+     &0.0112556,0.0094019,0.0079691,0.0073517,0.0068074,
+     &0.0062553,0.0058107,0.0053889,0.0049634,0.0045574,
+     &0.0043685,0.0042020,0.0040541,0.0040013,0.0040349,
+     &0.0041445,0.0041994,0.0041524,0.0039878,0.0038609,
+     &0.0037426,0.0036932,0.0036563,0.0036177,0.0035376,
+     &0.0034454,0.0033390,0.0032297,0.0030226,0.0028803,
+     &0.0027832,0.0026872,0.0026783,0.0026373,0.0025813,
+     &0.0025507,0.0025227,0.0024990,0.0024694,0.0024103,
+     &0.0023370,0.0022120,0.0021112,0.0020491,0.0019000,
+     &0.0017298,0.0016389,0.0015661,0.0014226,0.0012886,
+     &0.0011617,0.0008021,0.0005148,0.0004169/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.02
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.02	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.02	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 2 MICRONS (Franck Montmessin)
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=5.5E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=2.e-6,qrefice=2.55)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0770404,2.1333470,2.4010422,2.4979005,3.0323684,
+     &3.1023693,1.8456773,0.6115797,1.2549678,1.4533914,
+     &1.6278559,1.7319367,1.8213371,1.9134820,2.0143185,
+     &2.1186094,2.2303414,2.3434513,2.4327984,2.4951937,
+     &2.5413978,2.5864980,2.6369226,2.6951535,2.7622788,
+     &2.8332534,2.8984516,2.9598370,3.0300596,3.0575798,
+     &3.0930560,3.1250999,3.1535439,3.1871719,3.2121134,
+     &3.2310603,3.2315695,3.2093773,3.1794426,3.1392601,
+     &3.0919006,2.9505072,2.7231605,2.6405320,2.5163631,
+     &2.3446450,2.1814499,2.0090101,1.8916085,1.8633907,
+     &1.8338290,1.8152963,1.8086077,1.8112632,1.8131738,
+     &1.7060630,1.5370420,1.4517928/
+       data epiceir/
+     &1.3677877,1.2895485,1.2393701,1.1429415,1.0560902,
+     &1.0034354,0.9967221,0.9962561,0.9977396,1.0125090,
+     &1.0341120,1.0880692,1.1033542,1.0976548,1.0879265,
+     &1.0804520,1.0700891,1.0510827,1.0297735,1.0111766,
+     &0.9773523,0.9594117,0.9459089,0.9159908,0.8764862,
+     &0.8542295,0.8300154,0.7979962,0.7717778,0.7486199,
+     &0.7285973,0.7015588,0.6676357,0.6260576,0.5785204,
+     &0.5338926,0.5080446,0.4684776,0.4333192,0.4139500,
+     &0.3915187,0.3532456,0.3098173,0.2878825,0.3012615,
+     &0.3171561,0.3421502,0.3891775,0.4544489,0.5433146,
+     &0.6361080,0.7489142,0.8315196,0.9866923,1.0865711,
+     &1.1662428,1.2104664,1.2263397,1.2011900,1.1775792,
+     &1.1506165,1.1109692,1.0695655,1.0244781,0.9760489,
+     &0.9209963,0.8573869,0.7222608,0.6077753,0.5570301,
+     &0.5179734,0.4515876,0.4286255,0.4101167,0.3839801,
+     &0.3538276,0.2605970,0.2226936,0.2192847,0.2094082,
+     &0.1883334,0.1602530,0.1354466,0.0878593,0.0806558,
+     &0.0747401,0.0696599,0.0635099,0.0620812,0.0608565,
+     &0.0708767,0.0859044,0.1087823,0.1332179,0.1678403,
+     &0.2047173,0.2441402,0.2811615,0.3213149,0.3657669,
+     &0.4021912,0.4198142,0.4433846,0.4508493,0.4361142,
+     &0.3870594,0.3401732,0.3004933,0.2788217,0.2592098,
+     &0.2339364,0.2185203,0.2035674,0.1773828,0.1576549,
+     &0.1412068,0.1290261,0.1220045,0.1392276,0.1544823,
+     &0.1700448,0.1902850,0.1939131,0.1865104,0.1808444,
+     &0.1743156,0.1667072,0.1563581,0.1424541,0.1275658,
+     &0.1140205,0.0962364,0.0843266,0.0779076,0.0582227,
+     &0.0489812,0.0453767,0.0424055,0.0373608,0.0329743,
+     &0.0294211,0.0211810,0.0134449,0.0103372/
+       data omegicevis/
+     &0.5456115,0.9999998,0.9999956,0.9999590,0.9916146,
+     &0.9859025,0.9887677,0.3030088,0.2913164,0.3281876,
+     &0.3529492,0.3651998,0.3768913,0.3895164,0.4031501,
+     &0.4161578,0.4291025,0.4413079,0.4489263,0.4537341,
+     &0.4575938,0.4624165,0.4686106,0.4772439,0.4906920,
+     &0.5103999,0.5342540,0.5620137,0.6054875,0.6363699,
+     &0.6767519,0.7208792,0.7611457,0.8031358,0.8346425,
+     &0.8628765,0.8866344,0.9024555,0.9187659,0.9315375,
+     &0.9414928,0.9542499,0.9594395,0.9604324,0.9575609,
+     &0.9427309,0.9280359,0.9029658,0.8663382,0.8482844,
+     &0.8309193,0.8149818,0.8138757,0.8108203,0.8191826,
+     &0.8778344,0.8991383,0.9015617/
+       data omegiceir/
+     &0.8934232,0.8818511,0.8737661,0.8382167,0.7786070,
+     &0.6939076,0.6735601,0.6493360,0.6269631,0.5988325,
+     &0.5805314,0.5477262,0.5506567,0.5654900,0.5726005,
+     &0.5761235,0.5833758,0.5930895,0.5978242,0.5985849,
+     &0.5960529,0.5830086,0.5764220,0.5759224,0.5773382,
+     &0.5725862,0.5723791,0.5748378,0.5679526,0.5619652,
+     &0.5570325,0.5608990,0.5682156,0.5793377,0.5887846,
+     &0.5845600,0.5571433,0.5294130,0.4933869,0.4654703,
+     &0.4418373,0.4019260,0.3476712,0.2847430,0.1985389,
+     &0.1588668,0.1246927,0.0997362,0.0880947,0.0885516,
+     &0.0949879,0.1061776,0.1158887,0.1351058,0.1506025,
+     &0.1648239,0.1789169,0.1923770,0.2058806,0.2128322,
+     &0.2198936,0.2270511,0.2336397,0.2410020,0.2492446,
+     &0.2583708,0.2685325,0.2880028,0.2994628,0.3033591,
+     &0.3015518,0.2984661,0.2927081,0.2880204,0.2918781,
+     &0.2983889,0.3187046,0.3071705,0.2860579,0.2815239,
+     &0.2940739,0.3184738,0.3403679,0.3687520,0.3625693,
+     &0.3473680,0.3237919,0.2777646,0.2580903,0.2082118,
+     &0.1032983,0.0523547,0.0255129,0.0169770,0.0125923,
+     &0.0104937,0.0098291,0.0097139,0.0098247,0.0101194,
+     &0.0108076,0.0114394,0.0123597,0.0134295,0.0146494,
+     &0.0156162,0.0159481,0.0155375,0.0147876,0.0145659,
+     &0.0146613,0.0148656,0.0152911,0.0160210,0.0162369,
+     &0.0162299,0.0157726,0.0147472,0.0112574,0.0095320,
+     &0.0086141,0.0081565,0.0082618,0.0086479,0.0087967,
+     &0.0089716,0.0091790,0.0094908,0.0098519,0.0101090,
+     &0.0102865,0.0104608,0.0105742,0.0106353,0.0118091,
+     &0.0111652,0.0106810,0.0103373,0.0095315,0.0087433,
+     &0.0078753,0.0051297,0.0033094,0.0028262/
+       data gicevis/
+     &0.9484491,0.8355189,0.7778400,0.7776268,0.8190585,
+     &0.8606436,0.8731218,0.8806872,0.8701044,0.8643763,
+     &0.8590536,0.8557699,0.8518856,0.8469009,0.8408017,
+     &0.8344239,0.8276296,0.8213363,0.8196754,0.8210629,
+     &0.8234175,0.8239279,0.8233964,0.8221809,0.8193476,
+     &0.8139911,0.8067252,0.7971323,0.7828836,0.7760382,
+     &0.7660869,0.7580626,0.7531731,0.7496098,0.7489922,
+     &0.7482402,0.7481378,0.7496041,0.7509772,0.7528265,
+     &0.7546561,0.7586707,0.7610235,0.7611462,0.7609918,
+     &0.7593807,0.7559055,0.7519168,0.7489015,0.7477896,
+     &0.7452020,0.7419832,0.7389061,0.7381128,0.7358862,
+     &0.7217935,0.7082421,0.7019699/
+       data giceir/
+     &0.6960046,0.6900042,0.6861350,0.6780239,0.6687398,
+     &0.6597540,0.6579545,0.6563612,0.6546398,0.6533316,
+     &0.6517801,0.6404516,0.6350707,0.6258222,0.6224794,
+     &0.6192569,0.6158453,0.6121228,0.6084902,0.6050581,
+     &0.5983168,0.5919929,0.5853947,0.5746408,0.5632364,
+     &0.5555539,0.5475681,0.5390213,0.5306059,0.5220675,
+     &0.5134400,0.5042357,0.4944685,0.4842367,0.4735520,
+     &0.4627753,0.4524445,0.4363809,0.4197907,0.4085655,
+     &0.3969283,0.3785424,0.3589033,0.3451340,0.3322701,
+     &0.3254838,0.3188725,0.3129705,0.3078346,0.3038980,
+     &0.3000817,0.2968043,0.2943990,0.2886447,0.2820266,
+     &0.2753667,0.2682444,0.2614060,0.2542432,0.2503684,
+     &0.2464747,0.2424094,0.2378109,0.2329219,0.2279974,
+     &0.2228620,0.2168691,0.2037218,0.1898008,0.1828437,
+     &0.1758485,0.1631169,0.1571932,0.1515194,0.1461390,
+     &0.1406711,0.1239195,0.1134407,0.1088622,0.1045607,
+     &0.1002667,0.0957376,0.0912288,0.0785050,0.0754995,
+     &0.0722006,0.0684929,0.0624823,0.0602997,0.0553188,
+     &0.0450513,0.0376778,0.0319985,0.0295693,0.0274262,
+     &0.0252342,0.0234632,0.0217670,0.0200484,0.0184050,
+     &0.0176370,0.0169397,0.0163182,0.0160728,0.0161649,
+     &0.0165620,0.0167632,0.0165711,0.0159091,0.0153961,
+     &0.0149173,0.0147177,0.0145685,0.0144148,0.0140963,
+     &0.0137293,0.0133060,0.0128724,0.0120525,0.0114887,
+     &0.0111030,0.0107191,0.0106819,0.0105141,0.0102884,
+     &0.0101648,0.0100523,0.0099577,0.0098403,0.0096062,
+     &0.0093154,0.0088192,0.0084187,0.0081718,0.0075791,
+     &0.0069006,0.0065386,0.0062486,0.0056770,0.0051429,
+     &0.0046372,0.0032037,0.0020571,0.0016664/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.03
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.03	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.03	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice: PARTICLE RADIUS = 3 MICRONS (Franck Montmessin)
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=2.5E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=3.e-6,qrefice=2.2)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0594757,2.0556829,2.2896707,2.3257456,2.5099661,
+     &2.9161227,2.8020720,0.9336269,1.5134708,1.6889371,
+     &1.8322314,1.9146321,1.9831489,2.0514481,2.1239402,
+     &2.1971617,2.2737679,2.3492715,2.4073563,2.4458375,
+     &2.4726937,2.4971056,2.5221505,2.5486584,2.5773935,
+     &2.6081295,2.6391418,2.6699214,2.7093878,2.7364888,
+     &2.7674158,2.8051183,2.8506889,2.9136717,2.9810331,
+     &3.0470915,3.0933173,3.1121876,3.1349294,3.1638598,
+     &3.1912117,3.2744172,3.2761116,3.2431061,3.2102768,
+     &3.1776469,3.0866187,2.9577594,2.8526461,2.8176398,
+     &2.7821639,2.7549253,2.7503767,2.7499533,2.7608297,
+     &2.7274404,2.5991304,2.5173609/
+       data epiceir/
+     &2.4190733,2.3199425,2.2540693,2.1095867,1.9555371,
+     &1.8269345,1.8036077,1.7855358,1.7711544,1.7690116,
+     &1.7829260,1.8295234,1.8549844,1.8687238,1.8656639,
+     &1.8619236,1.8579320,1.8448261,1.8235378,1.8017112,
+     &1.7578924,1.7259388,1.7054915,1.6687690,1.6185619,
+     &1.5858195,1.5535859,1.5112923,1.4703351,1.4347173,
+     &1.4047177,1.3697965,1.3251381,1.2680571,1.1960392,
+     &1.1172380,1.0578237,0.9745934,0.8949080,0.8474779,
+     &0.7968613,0.7102672,0.6077121,0.5407101,0.5224510,
+     &0.5266400,0.5439359,0.5927324,0.6681964,0.7765685,
+     &0.8902640,1.0280455,1.1302272,1.3228931,1.4579507,
+     &1.5726897,1.6591437,1.7202030,1.7452124,1.7473249,
+     &1.7453249,1.7290004,1.7075497,1.6815135,1.6501899,
+     &1.6082871,1.5523466,1.4047438,1.2489705,1.1717392,
+     &1.1052268,0.9884429,0.9432285,0.9081387,0.8657278,
+     &0.8152991,0.6394543,0.5499370,0.5321090,0.5103995,
+     &0.4716277,0.4179623,0.3657534,0.2508311,0.2299716,
+     &0.2108125,0.1924924,0.1673682,0.1598235,0.1464571,
+     &0.1420538,0.1533015,0.1798090,0.2135266,0.2636204,
+     &0.3173732,0.3756316,0.4310254,0.4916850,0.5594596,
+     &0.6165060,0.6480070,0.6899570,0.7094871,0.6969641,
+     &0.6295437,0.5589720,0.4951279,0.4591832,0.4279796,
+     &0.3880569,0.3635468,0.3400364,0.2975883,0.2645470,
+     &0.2365445,0.2152134,0.2020684,0.2264057,0.2488454,
+     &0.2725164,0.3044016,0.3105968,0.3001241,0.2917667,
+     &0.2818419,0.2701418,0.2540473,0.2319813,0.2079458,
+     &0.1858774,0.1567208,0.1371507,0.1266034,0.0947660,
+     &0.0791723,0.0730714,0.0680956,0.0596443,0.0523504,
+     &0.0464472,0.0328870,0.0206243,0.0157984/
+       data omegicevis/
+     &0.5478598,0.9999998,0.9999930,0.9999391,0.9852892,
+     &0.9747255,0.9896471,0.3921073,0.3646954,0.3975615,
+     &0.4174147,0.4264744,0.4352827,0.4448440,0.4550543,
+     &0.4644430,0.4733422,0.4809923,0.4836857,0.4835298,
+     &0.4823884,0.4821825,0.4822653,0.4822173,0.4828566,
+     &0.4861327,0.4930841,0.5041330,0.5267492,0.5471958,
+     &0.5780509,0.6176673,0.6584746,0.7053177,0.7443977,
+     &0.7823801,0.8173603,0.8434741,0.8708835,0.8929197,
+     &0.9106523,0.9344197,0.9465593,0.9499664,0.9501572,
+     &0.9384264,0.9281004,0.9095014,0.8796501,0.8642664,
+     &0.8496780,0.8360837,0.8353950,0.8325557,0.8399941,
+     &0.8961539,0.9191431,0.9229702/
+       data omegiceir/
+     &0.9181703,0.9106198,0.9053057,0.8796571,0.8349904,
+     &0.7679166,0.7511637,0.7306502,0.7113808,0.6862068,
+     &0.6691588,0.6380840,0.6405194,0.6548850,0.6619208,
+     &0.6655905,0.6727100,0.6823230,0.6875201,0.6890487,
+     &0.6883412,0.6776634,0.6725497,0.6736822,0.6769779,
+     &0.6740052,0.6752223,0.6791695,0.6745857,0.6706817,
+     &0.6675888,0.6726563,0.6810013,0.6928600,0.7032822,
+     &0.7016219,0.6788723,0.6561857,0.6251051,0.5999153,
+     &0.5784231,0.5407491,0.4858367,0.4156316,0.3081297,
+     &0.2542117,0.2051306,0.1674406,0.1491730,0.1494159,
+     &0.1588227,0.1749455,0.1886469,0.2149218,0.2356885,
+     &0.2543647,0.2729447,0.2907736,0.3091933,0.3188552,
+     &0.3287012,0.3389443,0.3486176,0.3593718,0.3712797,
+     &0.3844498,0.3992367,0.4283787,0.4480617,0.4557256,
+     &0.4565090,0.4582297,0.4537602,0.4503480,0.4573702,
+     &0.4677775,0.5004078,0.4921789,0.4687816,0.4652704,
+     &0.4829984,0.5146720,0.5423340,0.5802344,0.5751773,
+     &0.5603711,0.5358865,0.4843219,0.4606548,0.3958648,
+     &0.2311990,0.1309277,0.0689810,0.0473044,0.0357645,
+     &0.0302096,0.0285216,0.0283661,0.0288575,0.0298694,
+     &0.0319034,0.0337869,0.0364643,0.0395041,0.0429032,
+     &0.0455614,0.0464966,0.0454506,0.0435048,0.0429859,
+     &0.0433492,0.0439662,0.0451907,0.0472841,0.0479729,
+     &0.0480491,0.0468699,0.0440733,0.0341798,0.0291907,
+     &0.0265080,0.0251720,0.0254859,0.0266501,0.0271129,
+     &0.0276442,0.0282702,0.0292041,0.0302890,0.0310830,
+     &0.0316508,0.0322409,0.0326373,0.0328552,0.0364115,
+     &0.0346299,0.0332475,0.0322650,0.0299256,0.0276080,
+     &0.0250169,0.0166050,0.0108650,0.0093190/
+       data gicevis/
+     &0.9487292,0.8501517,0.8084917,0.8064129,0.7796354,
+     &0.8265753,0.9093526,0.9365674,0.9241107,0.9169607,
+     &0.9102123,0.9061169,0.9015271,0.8957432,0.8886193,
+     &0.8810557,0.8728880,0.8651341,0.8625306,0.8636174,
+     &0.8661903,0.8671943,0.8675743,0.8681570,0.8683062,
+     &0.8662376,0.8610609,0.8520109,0.8346523,0.8228595,
+     &0.8053397,0.7876619,0.7732534,0.7589003,0.7500000,
+     &0.7413471,0.7345427,0.7344642,0.7366309,0.7405840,
+     &0.7467821,0.7644036,0.7784136,0.7846442,0.7965618,
+     &0.8083032,0.8136568,0.8199432,0.8255728,0.8271201,
+     &0.8275242,0.8268972,0.8249819,0.8245324,0.8223208,
+     &0.8117355,0.8062472,0.8041336/
+       data giceir/
+     &0.8028125,0.8016422,0.8009415,0.7998557,0.7981417,
+     &0.7963558,0.7960360,0.7959067,0.7956044,0.7956340,
+     &0.7950525,0.7882976,0.7844244,0.7777230,0.7753325,
+     &0.7731695,0.7707492,0.7681598,0.7659332,0.7639940,
+     &0.7603320,0.7571294,0.7533165,0.7466281,0.7393790,
+     &0.7345678,0.7292926,0.7235673,0.7182128,0.7126561,
+     &0.7069229,0.7005080,0.6936766,0.6865230,0.6792384,
+     &0.6722496,0.6657850,0.6547473,0.6428918,0.6345846,
+     &0.6255974,0.6109424,0.5946515,0.5828903,0.5715944,
+     &0.5652506,0.5587830,0.5527261,0.5470884,0.5424237,
+     &0.5377048,0.5334029,0.5303385,0.5231666,0.5153511,
+     &0.5072109,0.4983860,0.4895755,0.4802338,0.4751357,
+     &0.4699576,0.4646551,0.4586791,0.4522615,0.4457387,
+     &0.4389421,0.4309897,0.4133823,0.3940207,0.3839259,
+     &0.3734751,0.3533985,0.3436313,0.3339687,0.3244507,
+     &0.3145035,0.2824177,0.2612788,0.2519038,0.2428105,
+     &0.2333613,0.2230495,0.2126012,0.1826718,0.1755434,
+     &0.1677177,0.1589084,0.1445894,0.1393903,0.1275548,
+     &0.1034226,0.0862908,0.0732680,0.0678129,0.0630464,
+     &0.0581228,0.0541460,0.0502856,0.0463469,0.0425679,
+     &0.0408138,0.0391414,0.0376537,0.0370017,0.0370768,
+     &0.0378109,0.0381619,0.0376564,0.0360912,0.0348694,
+     &0.0337249,0.0332462,0.0328845,0.0325112,0.0317704,
+     &0.0309227,0.0299524,0.0289665,0.0271364,0.0258780,
+     &0.0250178,0.0241542,0.0240672,0.0236685,0.0231454,
+     &0.0228576,0.0225964,0.0223764,0.0221073,0.0215770,
+     &0.0209200,0.0198007,0.0188984,0.0183424,0.0170089,
+     &0.0154822,0.0146694,0.0140185,0.0127366,0.0115393,
+     &0.0104058,0.0071931,0.0046216,0.0037448/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.04
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.04	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.04	(revision 57)
@@ -0,0 +1,199 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 4 MICRONS (Franck Montmessin)
+
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=2.1E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=4.e-6,qrefice=2.1)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1802000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8197000E-05,
+     &.8333000E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680000E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0854822,2.0504486,2.2594056,2.2905577,2.4309553,
+     &2.7394925,2.9738858,1.0479889,1.5827071,1.7473683,
+     &1.8791661,1.9542847,2.0162247,2.0774747,2.1420606,
+     &2.2070080,2.2746674,2.3410056,2.3915425,2.4243052,
+     &2.4465380,2.4664531,2.4864873,2.5070593,2.5285199,
+     &2.5506347,2.5724538,2.5936350,2.6196233,2.6374214,
+     &2.6572831,2.6830637,2.7173599,2.7675186,2.8233521,
+     &2.8801521,2.9195511,2.9341195,2.9565225,2.9903221,
+     &3.0211312,3.1489194,3.2117107,3.1927426,3.1992998,
+     &3.2346768,3.1870882,3.0997686,3.0240328,2.9942008,
+     &2.9638598,2.9380857,2.9347956,2.9330930,2.9452588,
+     &2.9445502,2.8607601,2.7946008/
+       data epiceir/
+     &2.7047184,2.6120941,2.5504249,2.4083079,2.2449776,
+     &2.0963051,2.0678715,2.0435539,2.0233198,2.0134084,
+     &2.0220503,2.0596078,2.0865511,2.1071296,2.1073430,
+     &2.1056444,2.1049262,2.0960135,2.0772534,2.0565253,
+     &2.0132797,1.9785371,1.9572351,1.9217145,1.8724474,
+     &1.8385008,1.8061319,1.7637404,1.7201956,1.6824483,
+     &1.6508880,1.6160781,1.5712145,1.5128543,1.4363862,
+     &1.3483616,1.2774042,1.1795400,1.0840162,1.0261202,
+     &0.9651563,0.8602540,0.7339102,0.6469975,0.6119478,
+     &0.6091090,0.6207982,0.6672347,0.7434798,0.8558041,
+     &0.9740046,1.1170480,1.2233814,1.4233819,1.5659507,
+     &1.6880697,1.7848208,1.8579589,1.8989074,1.9101462,
+     &1.9175409,1.9114984,1.8998538,1.8840935,1.8632078,
+     &1.8316492,1.7857095,1.6508096,1.4954219,1.4151742,
+     &1.3432500,1.2148845,1.1631782,1.1234219,1.0776615,
+     &1.0225006,0.8207632,0.7104143,0.6854881,0.6592867,
+     &0.6146109,0.5515194,0.4878044,0.3406532,0.3125988,
+     &0.2862523,0.2605937,0.2247351,0.2136279,0.1929169,
+     &0.1780802,0.1848382,0.2104575,0.2466988,0.3018862,
+     &0.3613543,0.4261933,0.4881637,0.5562663,0.6325883,
+     &0.6974163,0.7349945,0.7849246,0.8107314,0.8016415,
+     &0.7301529,0.6518985,0.5788133,0.5371399,0.5015947,
+     &0.4561899,0.4281780,0.4014403,0.3523277,0.3134494,
+     &0.2802024,0.2545224,0.2382317,0.2645295,0.2893848,
+     &0.3160831,0.3526863,0.3600670,0.3487748,0.3395592,
+     &0.3284123,0.3151843,0.2968681,0.2714744,0.2435622,
+     &0.2178014,0.1836341,0.1606565,0.1482674,0.1111388,
+     &0.0925535,0.0852699,0.0793584,0.0693137,0.0606733,
+     &0.0536815,0.0376899,0.0234903,0.0179599/
+       data omegicevis/
+     &0.9997557,0.9999997,0.9999922,0.9999319,0.9834057,
+     &0.9697400,0.9889413,0.4170863,0.3839164,0.4148017,
+     &0.4329225,0.4410049,0.4489707,0.4576899,0.4670268,
+     &0.4755634,0.4835813,0.4903115,0.4920676,0.4910262,
+     &0.4890484,0.4880903,0.4873634,0.4862187,0.4850952,
+     &0.4856144,0.4890416,0.4960548,0.5125623,0.5285751,
+     &0.5546114,0.5898761,0.6277213,0.6730058,0.7122949,
+     &0.7517495,0.7888858,0.8171780,0.8476295,0.8725174,
+     &0.8933310,0.9217324,0.9365012,0.9409229,0.9421082,
+     &0.9300490,0.9206304,0.9031980,0.8741305,0.8588691,
+     &0.8445156,0.8310569,0.8304268,0.8275097,0.8349118,
+     &0.8934678,0.9187520,0.9234176/
+       data omegiceir/
+     &0.9195789,0.9130654,0.9084498,0.8848193,0.8432430,
+     &0.7802753,0.7644560,0.7449288,0.7265303,0.7022048,
+     &0.6854911,0.6547806,0.6568891,0.6708937,0.6778638,
+     &0.6815536,0.6886025,0.6981948,0.7035849,0.7054032,
+     &0.7053613,0.6954878,0.6908569,0.6925153,0.6964372,
+     &0.6940646,0.6957520,0.7002053,0.6964250,0.6932367,
+     &0.6907555,0.6961634,0.7047681,0.7167735,0.7274370,
+     &0.7265938,0.7055041,0.6847062,0.6557705,0.6320110,
+     &0.6117497,0.5758710,0.5225218,0.4523725,0.3413817,
+     &0.2842636,0.2313632,0.1900614,0.1697527,0.1697629,
+     &0.1798291,0.1970501,0.2115807,0.2391071,0.2606377,
+     &0.2798113,0.2988472,0.3170983,0.3361139,0.3461500,
+     &0.3563966,0.3671677,0.3774159,0.3888194,0.4014468,
+     &0.4154617,0.4312829,0.4628420,0.4848666,0.4936416,
+     &0.4953880,0.4988511,0.4951004,0.4923347,0.5001683,
+     &0.5114973,0.5471412,0.5407871,0.5179877,0.5151565,
+     &0.5338754,0.5665359,0.5949027,0.6346611,0.6304472,
+     &0.6168448,0.5937971,0.5441191,0.5208242,0.4555555,
+     &0.2795748,0.1643928,0.0891554,0.0618627,0.0471263,
+     &0.0400198,0.0378990,0.0377831,0.0385226,0.0399469,
+     &0.0426608,0.0451856,0.0487382,0.0527340,0.0571690,
+     &0.0606253,0.0618599,0.0605589,0.0581096,0.0574950,
+     &0.0580301,0.0588644,0.0604849,0.0632511,0.0642014,
+     &0.0643580,0.0628783,0.0592713,0.0462856,0.0396805,
+     &0.0361116,0.0343350,0.0347561,0.0363269,0.0369600,
+     &0.0376791,0.0385242,0.0397799,0.0412408,0.0423222,
+     &0.0431063,0.0439387,0.0445039,0.0448168,0.0496150,
+     &0.0473067,0.0454896,0.0441976,0.0410999,0.0380139,
+     &0.0345402,0.0231292,0.0152373,0.0130964/
+       data gicevis/
+     &0.8343501,0.8539270,0.8165237,0.8181057,0.7824335,
+     &0.8121903,0.9116917,0.9469896,0.9339413,0.9264918,
+     &0.9194773,0.9152379,0.9105224,0.9045991,0.8973010,
+     &0.8895398,0.8811479,0.8731629,0.8704250,0.8714981,
+     &0.8741569,0.8753158,0.8759663,0.8770830,0.8782619,
+     &0.8777608,0.8743001,0.8669701,0.8513806,0.8396250,
+     &0.8215540,0.8018272,0.7843039,0.7655624,0.7525014,
+     &0.7398580,0.7289740,0.7259218,0.7254756,0.7268577,
+     &0.7324639,0.7521768,0.7661537,0.7739922,0.7902248,
+     &0.8065580,0.8156578,0.8255079,0.8347661,0.8373555,
+     &0.8387650,0.8389051,0.8371919,0.8368247,0.8344242,
+     &0.8242407,0.8213838,0.8203836/
+       data giceir/
+     &0.8202859,0.8204761,0.8207446,0.8218899,0.8224330,
+     &0.8225752,0.8226243,0.8228495,0.8228806,0.8232125,
+     &0.8228349,0.8170514,0.8134916,0.8073353,0.8051527,
+     &0.8032251,0.8010219,0.7986862,0.7967891,0.7952084,
+     &0.7923052,0.7898931,0.7867939,0.7811755,0.7750518,
+     &0.7710254,0.7664988,0.7615658,0.7570799,0.7523895,
+     &0.7475237,0.7419846,0.7361146,0.7300106,0.7239206,
+     &0.7182872,0.7132332,0.7041776,0.6943774,0.6874813,
+     &0.6799427,0.6676864,0.6541361,0.6444608,0.6352317,
+     &0.6299193,0.6244130,0.6191449,0.6140400,0.6095717,
+     &0.6048778,0.6003752,0.5971281,0.5896495,0.5818252,
+     &0.5736867,0.5649501,0.5561939,0.5469384,0.5418788,
+     &0.5367152,0.5314598,0.5255540,0.5191799,0.5126669,
+     &0.5058801,0.4979611,0.4805868,0.4616396,0.4517272,
+     &0.4414385,0.4213243,0.4114112,0.4014477,0.3914565,
+     &0.3809337,0.3465430,0.3234292,0.3130346,0.3027512,
+     &0.2918884,0.2798819,0.2676042,0.2318030,0.2231267,
+     &0.2135321,0.2026399,0.1847338,0.1781789,0.1631734,
+     &0.1323553,0.1103728,0.0936858,0.0867514,0.0807283,
+     &0.0744888,0.0694563,0.0645469,0.0595233,0.0546962,
+     &0.0524681,0.0503008,0.0483757,0.0475037,0.0475338,
+     &0.0483772,0.0487606,0.0480684,0.0460275,0.0444297,
+     &0.0429296,0.0423003,0.0418224,0.0413265,0.0403650,
+     &0.0392690,0.0380197,0.0367560,0.0344374,0.0328447,
+     &0.0317576,0.0306637,0.0305520,0.0300328,0.0293586,
+     &0.0289865,0.0286487,0.0283637,0.0280170,0.0273389,
+     &0.0265009,0.0250756,0.0239277,0.0232211,0.0215270,
+     &0.0195894,0.0185593,0.0177348,0.0161119,0.0145967,
+     &0.0131628,0.0091000,0.0058481,0.0047391/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.05
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.05	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.05	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 5 MICRONS (Franck Montmessin)
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=1.2E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=5.e-6,qrefice=2.1)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0428143,2.0440466,2.1968415,2.2153285,2.2960923,
+     &2.3659375,2.8867066,1.4714612,1.7771624,1.8997087,
+     &1.9929919,2.0451753,2.0872736,2.1281450,2.1707144,
+     &2.2132783,2.2573934,2.3003073,2.3321264,2.3514304,
+     &2.3634045,2.3739398,2.3842189,2.3941483,2.4037600,
+     &2.4129043,2.4213498,2.4291728,2.4373298,2.4419029,
+     &2.4471161,2.4538815,2.4630349,2.4742622,2.4854822,
+     &2.5033839,2.5176528,2.5136092,2.5134516,2.5263309,
+     &2.5060482,2.6094491,2.6798794,2.6632533,2.7183650,
+     &2.8463554,2.9012349,2.9348140,2.9701750,2.9754398,
+     &2.9789634,2.9716895,2.9712498,2.9672985,2.9738250,
+     &3.0348940,3.1332080,3.1466768/
+       data epiceir/
+     &3.1348512,3.1135170,3.0980451,3.0516498,2.9460745,
+     &2.7977514,2.7647121,2.7296543,2.6980081,2.6652355,
+     &2.6520360,2.6446781,2.6661332,2.7014117,2.7124405,
+     &2.7181728,2.7285180,2.7372139,2.7347012,2.7262812,
+     &2.7032161,2.6736920,2.6591630,2.6453030,2.6226292,
+     &2.5987844,2.5791478,2.5533869,2.5169418,2.4857807,
+     &2.4605293,2.4401815,2.4123871,2.3720129,2.3076501,
+     &2.2154198,2.1208081,1.9929006,1.8554076,1.7655714,
+     &1.6732348,1.5088136,1.2957467,1.1248519,1.0043060,
+     &0.9623911,0.9399940,0.9638529,1.0305194,1.1452191,
+     &1.2687433,1.4178077,1.5291764,1.7348669,1.8864686,
+     &2.0165479,2.1304126,2.2267041,2.3057120,2.3408694,
+     &2.3737895,2.3992765,2.4196458,2.4389904,2.4559703,
+     &2.4664493,2.4680557,2.4285460,2.3429909,2.2869768,
+     &2.2235444,2.0965919,2.0351093,1.9889221,1.9465162,
+     &1.8934352,1.6640973,1.4980435,1.4440260,1.4054043,
+     &1.3498148,1.2628263,1.1601040,0.8777069,0.8140609,
+     &0.7497768,0.6831331,0.5837339,0.5504547,0.4820068,
+     &0.3904156,0.3576854,0.3641066,0.4038780,0.4747776,
+     &0.5532535,0.6412786,0.7272216,0.8227299,0.9304959,
+     &1.0245264,1.0890912,1.1736258,1.2312673,1.2493920,
+     &1.1830822,1.0889487,0.9851518,0.9227560,0.8740039,
+     &0.8118621,0.7720758,0.7351863,0.6589684,0.5922329,
+     &0.5316939,0.4811391,0.4445072,0.4707272,0.5020384,
+     &0.5401840,0.5982011,0.6122363,0.6017624,0.5915391,
+     &0.5768967,0.5586212,0.5319895,0.4920566,0.4455049,
+     &0.4009319,0.3399382,0.2980777,0.2753274,0.2093637,
+     &0.1716706,0.1567566,0.1449283,0.1247388,0.1076142,
+     &0.0937344,0.0625980,0.0375503,0.0283737/
+       data omegicevis/
+     &0.5494931,0.9999998,0.9999893,0.9999013,0.9758908,
+     &0.9520350,0.9813806,0.4902175,0.4373621,0.4608643,
+     &0.4736899,0.4790656,0.4847680,0.4913164,0.4985126,
+     &0.5050762,0.5111622,0.5159741,0.5158814,0.5132105,
+     &0.5098287,0.5077458,0.5059724,0.5035798,0.5004508,
+     &0.4974112,0.4955608,0.4956980,0.4999822,0.5055479,
+     &0.5182787,0.5389499,0.5644807,0.6003360,0.6358722,
+     &0.6744935,0.7115463,0.7406379,0.7754455,0.8046825,
+     &0.8330303,0.8720050,0.8909805,0.8971584,0.8986517,
+     &0.8775966,0.8676537,0.8459433,0.8139567,0.7968134,
+     &0.7813268,0.7666911,0.7660663,0.7625950,0.7705110,
+     &0.8471078,0.8871527,0.8974949/
+       data omegiceir/
+     &0.8977836,0.8945748,0.8924134,0.8738061,0.8388449,
+     &0.7859417,0.7726671,0.7557423,0.7397608,0.7176195,
+     &0.7014517,0.6706539,0.6709267,0.6829631,0.6896477,
+     &0.6933964,0.7002523,0.7101147,0.7166997,0.7200235,
+     &0.7232453,0.7166191,0.7139632,0.7179898,0.7246478,
+     &0.7245268,0.7280882,0.7347864,0.7340991,0.7336202,
+     &0.7333983,0.7403341,0.7504411,0.7639143,0.7766036,
+     &0.7794099,0.7640404,0.7500795,0.7291497,0.7110402,
+     &0.6959369,0.6683127,0.6242461,0.5602421,0.4472759,
+     &0.3841803,0.3222430,0.2709396,0.2443090,0.2429399,
+     &0.2540719,0.2731242,0.2887707,0.3170114,0.3380532,
+     &0.3559635,0.3733418,0.3897057,0.4070157,0.4162955,
+     &0.4258323,0.4362862,0.4465349,0.4581154,0.4711562,
+     &0.4861186,0.5037051,0.5414228,0.5708696,0.5832593,
+     &0.5885317,0.5983726,0.5977412,0.5976148,0.6077798,
+     &0.6216503,0.6655161,0.6657503,0.6467597,0.6461229,
+     &0.6660358,0.6987826,0.7269489,0.7691699,0.7678677,
+     &0.7591690,0.7429094,0.7052954,0.6864988,0.6300915,
+     &0.4480666,0.2989470,0.1806929,0.1314649,0.1033070,
+     &0.0896708,0.0859415,0.0864679,0.0888946,0.0928023,
+     &0.0989119,0.1047399,0.1125751,0.1210458,0.1301845,
+     &0.1373109,0.1401302,0.1382077,0.1341803,0.1336529,
+     &0.1354927,0.1375671,0.1411836,0.1473035,0.1498776,
+     &0.1508872,0.1485618,0.1416996,0.1143930,0.0999223,
+     &0.0919109,0.0879268,0.0889088,0.0927174,0.0943725,
+     &0.0961518,0.0982119,0.1012073,0.1047162,0.1074747,
+     &0.1096113,0.1120945,0.1138527,0.1148487,0.1264241,
+     &0.1220450,0.1182757,0.1155932,0.1089078,0.1020501,
+     &0.0940495,0.0660757,0.0452682,0.0393932/
+       data gicevis/
+     &0.9488561,0.8622694,0.8421568,0.8444307,0.8198477,
+     &0.8025251,0.8924177,0.9702666,0.9557836,0.9476732,
+     &0.9401344,0.9356233,0.9306720,0.9244909,0.9168691,
+     &0.9087364,0.8999177,0.8914922,0.8885176,0.8896047,
+     &0.8924723,0.8939612,0.8951342,0.8972442,0.9004632,
+     &0.9036172,0.9051868,0.9042581,0.8988889,0.8931115,
+     &0.8817939,0.8662245,0.8491337,0.8268852,0.8078062,
+     &0.7890281,0.7693759,0.7548954,0.7426000,0.7296526,
+     &0.7270693,0.7355062,0.7289565,0.7364469,0.7544447,
+     &0.7692665,0.7925164,0.8065700,0.8307455,0.8377706,
+     &0.8427537,0.8454301,0.8436610,0.8436959,0.8396172,
+     &0.8239458,0.8273445,0.8320904/
+       data giceir/
+     &0.8373514,0.8419112,0.8460672,0.8574966,0.8670993,
+     &0.8753594,0.8769836,0.8787410,0.8801410,0.8817471,
+     &0.8821138,0.8790489,0.8760744,0.8707907,0.8689077,
+     &0.8674014,0.8654746,0.8634583,0.8622014,0.8614331,
+     &0.8604119,0.8602243,0.8590601,0.8563642,0.8534315,
+     &0.8516557,0.8491830,0.8464145,0.8443506,0.8419912,
+     &0.8393673,0.8359801,0.8324290,0.8288801,0.8258969,
+     &0.8241146,0.8232231,0.8199658,0.8160087,0.8130227,
+     &0.8095026,0.8040639,0.7986902,0.7954774,0.7927923,
+     &0.7908941,0.7887109,0.7863154,0.7833571,0.7799240,
+     &0.7757225,0.7708758,0.7671629,0.7589634,0.7514880,
+     &0.7439123,0.7363079,0.7288431,0.7213242,0.7172369,
+     &0.7129840,0.7087308,0.7039406,0.6985872,0.6929027,
+     &0.6868637,0.6798444,0.6653367,0.6513552,0.6442967,
+     &0.6372020,0.6223192,0.6148563,0.6068394,0.5979654,
+     &0.5884917,0.5583712,0.5388037,0.5299017,0.5197192,
+     &0.5079988,0.4946542,0.4810905,0.4402598,0.4297767,
+     &0.4177190,0.4033195,0.3778822,0.3680294,0.3443614,
+     &0.2904477,0.2472555,0.2122748,0.1975763,0.1849724,
+     &0.1717572,0.1611385,0.1505969,0.1396510,0.1290195,
+     &0.1242519,0.1192575,0.1148210,0.1125826,0.1120808,
+     &0.1130957,0.1133712,0.1114241,0.1063793,0.1023448,
+     &0.0985022,0.0968736,0.0956093,0.0943082,0.0919330,
+     &0.0892278,0.0861601,0.0830894,0.0777779,0.0741764,
+     &0.0717541,0.0693096,0.0690498,0.0677189,0.0660590,
+     &0.0651242,0.0642725,0.0635431,0.0626790,0.0610575,
+     &0.0590792,0.0557436,0.0530752,0.0514414,0.0475330,
+     &0.0431135,0.0407930,0.0389434,0.0353244,0.0319652,
+     &0.0288019,0.0198931,0.0127889,0.0103672/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.10
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.10	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/aerice.h.10	(revision 57)
@@ -0,0 +1,198 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'aerice.h'
+c Spectral  Radiative properties of water ice PARTICLE RADIUS = 10 MICRONS (Franck Montmessin)
+c (Warren, 1984)
+
+c visible 
+      integer nicevis
+      parameter(nicevis=58)
+      REAL longicevis(nicevis),epicevis(nicevis)
+     &    ,omegicevis(nicevis),gicevis(nicevis)
+
+
+c IR 
+      integer niceir
+      parameter(niceir=144)
+      REAL longiceir(niceir),epiceir(niceir)
+     &    ,omegiceir(niceir),giceir(niceir)
+
+c Ratio solsirice = Tau(vis) / Tau (9 microns)
+      REAL solsirice
+      PARAMETER (solsirice=0.8E+0)
+c Optical properties used by initracer.F to determine Qextrhor
+      REAL rcrystal,qrefice
+      PARAMETER (rcrystal=1.e-5,qrefice=2.1)
+c---------------------------------------------------------------------
+	     
+       data longicevis/
+     &.1033000E-06,.4000000E-06,.8000000E-06,.1000000E-05,.1504000E-05,
+     &.2000000E-05,.2600000E-05,.2817000E-05,.2899000E-05,.2915000E-05,
+     &.2933000E-05,.2950000E-05,.2967000E-05,.2985000E-05,.3003000E-05,
+     &.3021000E-05,.3040000E-05,.3058000E-05,.3077000E-05,.3096000E-05,
+     &.3115000E-05,.3135000E-05,.3155000E-05,.3175000E-05,.3195000E-05,
+     &.3215000E-05,.3236000E-05,.3257000E-05,.3279000E-05,.3300000E-05,
+     &.3322000E-05,.3345000E-05,.3367000E-05,.3390000E-05,.3413000E-05,
+     &.3436000E-05,.3460000E-05,.3484000E-05,.3509000E-05,.3534000E-05,
+     &.3559000E-05,.3624000E-05,.3732000E-05,.3775000E-05,.3847000E-05,
+     &.3969000E-05,.4099000E-05,.4239000E-05,.4348000E-05,.4387000E-05,
+     &.4444000E-05,.4505000E-05,.4547000E-05,.4560000E-05,.4580000E-05,
+     &.4719000E-05,.4904000E-05,.5000000E-05/
+       data longiceir/
+     &.5100000E-05,.5200000E-05,.5263000E-05,.5400000E-05,.5556000E-05,
+     &.5714000E-05,.5747000E-05,.5780000E-05,.5814000E-05,.5848000E-05,
+     &.5882000E-05,.6061000E-05,.6135000E-05,.6250000E-05,.6289000E-05,
+     &.6329000E-05,.6369000E-05,.6410000E-05,.6452000E-05,.6494000E-05,
+     &.6579000E-05,.6667000E-05,.6757000E-05,.6897000E-05,.7042000E-05,
+     &.7143000E-05,.7246000E-05,.7353000E-05,.7463000E-05,.7576000E-05,
+     &.7692000E-05,.7812000E-05,.7937000E-05,.8065000E-05,.8196999E-05,
+     &.8333001E-05,.8475000E-05,.8696000E-05,.8929000E-05,.9091000E-05,
+     &.9259000E-05,.9524000E-05,.9804000E-05,.1000000E-04,.1020000E-04,
+     &.1031000E-04,.1042000E-04,.1053000E-04,.1064000E-04,.1075000E-04,
+     &.1087000E-04,.1100000E-04,.1111000E-04,.1136000E-04,.1163000E-04,
+     &.1190000E-04,.1220000E-04,.1250000E-04,.1282000E-04,.1299000E-04,
+     &.1316000E-04,.1333000E-04,.1351000E-04,.1370000E-04,.1389000E-04,
+     &.1408000E-04,.1429000E-04,.1471000E-04,.1515000E-04,.1538000E-04,
+     &.1563000E-04,.1613000E-04,.1639000E-04,.1667000E-04,.1695000E-04,
+     &.1724000E-04,.1818000E-04,.1887000E-04,.1923000E-04,.1961000E-04,
+     &.2000000E-04,.2041000E-04,.2083000E-04,.2222000E-04,.2260000E-04,
+     &.2305000E-04,.2360000E-04,.2460000E-04,.2500000E-04,.2600000E-04,
+     &.2857000E-04,.3100000E-04,.3333000E-04,.3448000E-04,.3564000E-04,
+     &.3700000E-04,.3824000E-04,.3960000E-04,.4114000E-04,.4276000E-04,
+     &.4358000E-04,.4458000E-04,.4550000E-04,.4615000E-04,.4671000E-04,
+     &.4736000E-04,.4800000E-04,.4878000E-04,.5003000E-04,.5128000E-04,
+     &.5275000E-04,.5350000E-04,.5424000E-04,.5500000E-04,.5574000E-04,
+     &.5640000E-04,.5700000E-04,.5746000E-04,.5840000E-04,.5929000E-04,
+     &.6000000E-04,.6100000E-04,.6125000E-04,.6250000E-04,.6378000E-04,
+     &.6467000E-04,.6558000E-04,.6655000E-04,.6760000E-04,.6900000E-04,
+     &.7053000E-04,.7300000E-04,.7500000E-04,.7629000E-04,.8000000E-04,
+     &.8297000E-04,.8500000E-04,.8680001E-04,.9080000E-04,.9517000E-04,
+     &.1000000E-03,.1200000E-03,.1500000E-03,.1670000E-03/
+       data epicevis/
+     &2.0273049,2.0553651,2.1324184,2.1634929,2.1279089,
+     &2.2649884,2.2698500,2.0945108,1.9718964,2.0290234,
+     &2.0724838,2.0969706,2.1164510,2.1352997,2.1550443,
+     &2.1750197,2.1959615,2.2164886,2.2313924,2.2397768,
+     &2.2443697,2.2484777,2.2524328,2.2560196,2.2593305,
+     &2.2624981,2.2655437,2.2686977,2.2731700,2.2766244,
+     &2.2794294,2.2792618,2.2795415,2.2846086,2.2950807,
+     &2.3121541,2.3191226,2.3011398,2.2936110,2.2905064,
+     &2.2727025,2.3178666,2.3242922,2.3330655,2.3261759,
+     &2.3501878,2.3524554,2.3359809,2.3611195,2.3675768,
+     &2.3733923,2.3748493,2.3755083,2.3754752,2.3756132,
+     &2.3760719,2.4271755,2.3955469/
+       data epiceir/
+     &2.4612815,2.4641292,2.4568148,2.5147929,2.5530331,
+     &2.5705762,2.5728459,2.5721469,2.5704122,2.5617049,
+     &2.5519185,2.5355358,2.5353646,2.5456607,2.5519402,
+     &2.5570130,2.5640745,2.5747874,2.5854921,2.5940452,
+     &2.6071377,2.6118498,2.6188061,2.6403730,2.6669781,
+     &2.6775784,2.6885033,2.7046711,2.7192614,2.7353652,
+     &2.7494493,2.7692459,2.7941475,2.8259096,2.8570986,
+     &2.8766527,2.8766177,2.8746240,2.8368504,2.7997968,
+     &2.7614427,2.6663651,2.4818733,2.2510304,1.9602349,
+     &1.8146522,1.6854036,1.6102730,1.6048870,1.6705624,
+     &1.7576077,1.8667697,1.9497169,2.0947831,2.2019422,
+     &2.2885010,2.3667836,2.4332867,2.4948113,2.5246017,
+     &2.5532246,2.5817444,2.6085849,2.6368368,2.6661391,
+     &2.6972022,2.7322018,2.8090558,2.8837960,2.9189849,
+     &2.9399867,2.9627054,2.9581554,2.9556482,2.9702957,
+     &2.9914343,3.0622592,3.0227430,2.9683504,2.9483757,
+     &2.9425662,2.9222951,2.8775811,2.6872020,2.5973134,
+     &2.4775703,2.3277271,2.0808144,1.9930708,1.7932411,
+     &1.3749977,1.1105362,0.9519616,0.9414314,1.0029964,
+     &1.0884044,1.1978686,1.3110209,1.4375935,1.5781999,
+     &1.7028408,1.8087940,1.9384904,2.0478878,2.1342847,
+     &2.1552835,2.1219630,2.0431452,1.9908499,1.9683007,
+     &1.9452211,1.9265127,1.9173379,1.8556699,1.7696880,
+     &1.6679885,1.5544487,1.4389187,1.3726599,1.3709559,
+     &1.4067492,1.4992472,1.5341307,1.5684799,1.5883886,
+     &1.5933384,1.5931257,1.5828085,1.5444956,1.4816657,
+     &1.4080117,1.2855885,1.1866654,1.1282085,0.9652229,
+     &0.7942671,0.7229686,0.6674553,0.5672902,0.4800995,
+     &0.4058672,0.2359050,0.1220444,0.0873671/
+       data omegicevis/
+     &0.5504259,0.9999992,0.9999804,0.9997928,0.9548051,
+     &0.9126351,0.9571041,0.5516225,0.4932337,0.5069626,
+     &0.5145947,0.5177403,0.5216092,0.5264726,0.5321194,
+     &0.5374104,0.5423936,0.5462285,0.5453517,0.5420842,
+     &0.5383082,0.5359790,0.5340598,0.5316239,0.5284724,
+     &0.5251024,0.5221875,0.5200486,0.5182305,0.5173715,
+     &0.5181928,0.5213331,0.5280793,0.5438614,0.5659477,
+     &0.5936272,0.6220001,0.6461561,0.6788177,0.7087492,
+     &0.7393658,0.7893919,0.8146747,0.8209112,0.8149179,
+     &0.7802355,0.7582701,0.7185146,0.6685008,0.6464375,
+     &0.6278486,0.6119440,0.6113081,0.6078985,0.6163179,
+     &0.7056757,0.7598560,0.7761379/
+       data omegiceir/
+     &0.7759839,0.7669778,0.7639439,0.7364159,0.6928631,
+     &0.6428539,0.6326926,0.6199911,0.6088360,0.5931817,
+     &0.5812727,0.5587846,0.5566773,0.5620723,0.5661795,
+     &0.5687336,0.5732306,0.5805613,0.5866805,0.5907671,
+     &0.5969589,0.5957459,0.5962836,0.6028957,0.6124275,
+     &0.6156567,0.6218417,0.6321118,0.6370467,0.6411974,
+     &0.6447079,0.6546141,0.6691408,0.6888857,0.7109522,
+     &0.7267580,0.7246028,0.7274987,0.7256792,0.7211279,
+     &0.7193315,0.7149989,0.7013977,0.6651995,0.5782154,
+     &0.5228451,0.4628350,0.4070674,0.3747672,0.3693838,
+     &0.3776684,0.3927504,0.4044872,0.4236842,0.4359979,
+     &0.4452721,0.4529338,0.4591291,0.4647588,0.4675789,
+     &0.4704044,0.4736306,0.4769657,0.4809483,0.4857694,
+     &0.4920136,0.5005317,0.5248833,0.5530189,0.5680709,
+     &0.5790995,0.6006733,0.6076213,0.6135495,0.6271621,
+     &0.6453611,0.7096416,0.7277915,0.7180390,0.7214272,
+     &0.7430624,0.7781302,0.8105813,0.8638036,0.8667906,
+     &0.8650255,0.8590664,0.8432143,0.8341830,0.8032821,
+     &0.6736456,0.5327421,0.3821245,0.3023261,0.2506925,
+     &0.2248830,0.2181999,0.2206931,0.2274191,0.2371715,
+     &0.2492834,0.2612511,0.2759819,0.2907880,0.3061035,
+     &0.3189336,0.3259392,0.3269015,0.3248960,0.3278614,
+     &0.3352942,0.3411323,0.3492400,0.3630564,0.3716860,
+     &0.3780700,0.3789840,0.3714330,0.3232819,0.2950966,
+     &0.2783259,0.2697008,0.2717506,0.2816038,0.2868812,
+     &0.2919132,0.2975354,0.3052135,0.3144514,0.3230745,
+     &0.3308428,0.3415695,0.3497911,0.3546669,0.3859474,
+     &0.3858507,0.3821296,0.3797063,0.3712473,0.3611613,
+     &0.3470088,0.2835475,0.2232076,0.2036654/
+       data gicevis/
+     &0.9488313,0.8737755,0.8699134,0.8632549,0.8664746,
+     &0.8654723,0.8639066,0.9867598,0.9718844,0.9635127,
+     &0.9558461,0.9512742,0.9462659,0.9400148,0.9322755,
+     &0.9239700,0.9149156,0.9062143,0.9031032,0.9042205,
+     &0.9072103,0.9088409,0.9101745,0.9125225,0.9162391,
+     &0.9205437,0.9242871,0.9270018,0.9297845,0.9314710,
+     &0.9314710,0.9295564,0.9256747,0.9176448,0.9091137,
+     &0.8993065,0.8857244,0.8742417,0.8625565,0.8491372,
+     &0.8415641,0.8312504,0.8189208,0.8167353,0.8238611,
+     &0.8239230,0.8371644,0.8417686,0.8616024,0.8695507,
+     &0.8752736,0.8796579,0.8782625,0.8792304,0.8746206,
+     &0.8405395,0.8161123,0.8190467/
+       data giceir/
+     &0.8215228,0.8188539,0.8235543,0.8430634,0.8634555,
+     &0.8889333,0.8943647,0.9004826,0.9057037,0.9118157,
+     &0.9151983,0.9186423,0.9165455,0.9109817,0.9085578,
+     &0.9069400,0.9043546,0.9010347,0.8988791,0.8976911,
+     &0.8963661,0.8980653,0.8983047,0.8966079,0.8940747,
+     &0.8933308,0.8913805,0.8891829,0.8896720,0.8898105,
+     &0.8894080,0.8870043,0.8841559,0.8807722,0.8783676,
+     &0.8806533,0.8874398,0.8930346,0.8980618,0.9013399,
+     &0.9038298,0.9075544,0.9122803,0.9171227,0.9216645,
+     &0.9230088,0.9236676,0.9233609,0.9217389,0.9185820,
+     &0.9143328,0.9086544,0.9041949,0.8948452,0.8875402,
+     &0.8805291,0.8743904,0.8689287,0.8643938,0.8621209,
+     &0.8597336,0.8575692,0.8550812,0.8520836,0.8486272,
+     &0.8446994,0.8398250,0.8288277,0.8186790,0.8140771,
+     &0.8110483,0.8041257,0.8015433,0.7980613,0.7919027,
+     &0.7852415,0.7688640,0.7656652,0.7660689,0.7611709,
+     &0.7521669,0.7417981,0.7344227,0.7222472,0.7201254,
+     &0.7173442,0.7131014,0.7038283,0.6999976,0.6905708,
+     &0.6637480,0.6310949,0.5964675,0.5787684,0.5612767,
+     &0.5405343,0.5222011,0.5027949,0.4812989,0.4589987,
+     &0.4483198,0.4369166,0.4259420,0.4192472,0.4154068,
+     &0.4142449,0.4130682,0.4088767,0.3968293,0.3857591,
+     &0.3742922,0.3692816,0.3648685,0.3617240,0.3566430,
+     &0.3508260,0.3437443,0.3361050,0.3206013,0.3090643,
+     &0.3008432,0.2916748,0.2902482,0.2839455,0.2766951,
+     &0.2723766,0.2683532,0.2648085,0.2613389,0.2555560,
+     &0.2486358,0.2367881,0.2269753,0.2207384,0.2052476,
+     &0.1863302,0.1759822,0.1676274,0.1511226,0.1356524,
+     &0.1210628,0.0811427,0.0511400,0.0412876/
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blackl.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blackl.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blackl.F	(revision 57)
@@ -0,0 +1,20 @@
+      subroutine blackl(blalong,blat,blae)
+c.......................................................................
+      implicit double precision (a-h,o-z)
+c.......................................................................
+c.....donnees de fond
+      sigma=5.6693d-08
+      pi=datan(1.d0)*4.d0
+      c0=2.9979d+08
+      h=6.6262d-34
+      cbol=1.3806d-23
+      rind=1.d0
+      c=c0/rind
+      c1=h*(c**2)
+      c2=h*c/cbol
+c.....fin de donnees de fond
+c.......................................................................
+      blae=2.d0*pi*c1/blalong**5/(dexp(c2/blalong/blat)-1.d0)
+c.......................................................................
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blendrad.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blendrad.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/blendrad.F	(revision 57)
@@ -0,0 +1,60 @@
+      subroutine blendrad(ngrid, nlayer, pplay,
+     &                    zdtsw, zdtlw, zdtnirco2, zdtnlte, dtrad)
+c
+c  Combine radiative tendencies.  LTE contributions (zdtsw and zdtlw)
+c  have been calculated for the first NLAYLTE layers, zdtnirco2 and
+c  zdtnlte have been calculated for all nlayer layers (but zdtnlte may
+c  be zero low down).  zdtlw is phased out in favour of zdtnlte with
+c  height; zdtsw is also phased out to remove possible spurious heating
+c  at low pressures.  The pressure at which the transition occurs and
+c  the scale over which this happens are set in the nlteparams.h file.
+c  Above layer NLAYLTE the tendency is purely the sum of NLTE contributions.
+c  (Note : nlaylte is calculated by "nlthermeq" and stored in common "yomlw.h")
+c  Stephen Lewis 6/2000 FF 
+c
+      implicit none
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "nlteparams.h"
+#include "yomlw.h"
+
+c     Input:
+      integer ngrid, nlayer
+      real pplay(ngrid, nlayer)
+      real zdtlw(ngrid, nlayer)
+      real zdtsw(ngrid, nlayer)
+      real zdtnirco2(ngrid, nlayer)
+      real zdtnlte(ngrid, nlayer)
+c
+c     Output:
+      real dtrad(ngrid, nlayer)
+c
+c     Local:
+      integer l, ig
+      real alpha
+c
+c     This is split into two loops to minimize number of calculations,
+c     but for vector machines it may be faster to perform one big
+c     loop from 1 to nlayer and remove the second loop.
+c
+c     Loop over layers for which zdtsw/lw have been calculated.
+      do l = 1,nlaylte 
+         do ig = 1, ngrid
+c           alpha is actually 0.5*(1+tanh((z-ztrans)/zw))
+c           written here in a simpler form, with z=-ln(p) and zwi=2/zw
+            alpha = 1./(1.+(pplay(ig,l)/ptrans)**zwi)
+            dtrad(ig,l) = (1.-alpha)*(zdtsw(ig,l)+zdtlw(ig,l))
+     &                  + zdtnirco2(ig,l) + alpha*zdtnlte(ig,l)
+         enddo
+      enddo
+c
+c     Faster loop over any remaining layers.
+      do l = nlaylte+1, nlayer
+         do ig = 1, ngrid
+            dtrad(ig,l) = zdtnirco2(ig,l) + zdtnlte(ig,l)
+         enddo
+      enddo
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/calldrag_noro.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/calldrag_noro.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/calldrag_noro.F	(revision 57)
@@ -0,0 +1,203 @@
+      SUBROUTINE calldrag_noro(ngrid,nlayer,ptimestep,
+     &                 pplay,pplev,pt,pu,pv,pdtgw,pdugw,pdvgw) 
+
+
+
+                                                   
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Subroutine designed to call SUBROUTINE drag_noro 
+c   Interface for sub-grid scale orographic scheme
+c   The purpose of this subroutine is
+c      1) Make some initial calculation at first call
+c      2) Split the calculation in several sub-grid
+c        ("sub-domain") to save memory and
+c        be able run on a workstation at high resolution
+c        The sub-grid size is defined in dimradmars.h
+c
+c   author:   
+c   ------
+c           Christophe Hourdin/ Francois Forget
+c
+c   input:
+c   ----- 
+c   ngrid                 number of gridpoint of horizontal grid
+c   nlayer                Number of layer
+c   ptimestep             Physical timestep (s)
+c   pplay(ngrid,nlayer)    pressure (Pa) in the middle of each layer
+c   pplev(ngrid,nlayer+1)  pressure (Pa) at boundaries of each layer
+c   pt(ngrid,nlayer)       atmospheric temperature  (K)
+c   pu(ngrid,nlayer)       zonal wind (m s-1)
+c   pv(ngrid,nlayer)       meridional wind (m s-1)
+c
+c   output:
+c   -------
+c   pdtgw(ngrid,nlayer)    Temperature trend (K.s-1)
+c   pdugw(ngrid,nlayer)    zonal wind trend  (m.s-2)
+c   pdvgw(ngrid,nlayer)    meridional wind trend  (m.s-2)
+c
+c
+c
+c
+c
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "surfdat.h"
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER ngrid,nlayer  
+
+      real ptimestep
+
+      REAL pplev(ngrid,nlayer+1),pplay(ngrid,nlayer)
+      REAL pt(ngrid,nlayer), pu(ngrid,nlayer),pv(ngrid,nlayer)
+      REAL pdtgw(ngrid,nlayer), pdugw(ngrid,nlayer),pdvgw(ngrid,nlayer)
+
+
+c
+c    Local variables :
+c    -----------------
+
+      REAL sigtest(nlayermx+1)
+      INTEGER igwd,igwdim,itest(ngridmx)
+
+      INTEGER ndomain
+      parameter (ndomain = (ngridmx-1) / ndomainsz + 1)
+
+      INTEGER l,ig
+      INTEGER jd,ig0,nd
+
+      REAL zulow(ngridmx),zvlow(ngridmx)
+      REAL zustr(ngridmx),zvstr(ngridmx)
+
+
+      REAL zplev(ndomainsz,nlayermx+1)
+      REAL zplay(ndomainsz,nlayermx)
+      REAL zt(ndomainsz,nlayermx)
+      REAL zu(ndomainsz,nlayermx)
+      REAL zv(ndomainsz,nlayermx)
+      INTEGER zidx(ndomainsz)
+      REAL zzdtgw(ndomainsz,nlayermx)
+      REAL zzdugw(ndomainsz,nlayermx)
+      REAL zzdvgw(ndomainsz,nlayermx)
+
+      logical ll
+
+
+c   local saved variables
+c   ---------------------
+
+      LOGICAL firstcall
+      DATA firstcall/.true./
+      SAVE firstcall
+
+
+c----------------------------------------------------------------------
+
+c     Initialisation
+c     --------------
+
+      IF (firstcall) THEN
+         do l=1,nlayermx+1
+           sigtest(l)=pplev(1,l)/pplev(1,1)
+         enddo
+         call sugwd(nlayermx,sigtest)
+
+         if (ngridmx .EQ. 1) then
+           if (ndomainsz .NE. 1) then
+             print*
+             print*,'ATTENTION !!!'
+             print*,'pour tourner en 1D, meme pour drag_noro '
+             print*,'fixer ndomainsz=1 dans phymars/dimradmars.h'
+             print*
+             call exit(1)
+           endif
+         endif
+
+         firstcall=.false.
+      END IF
+
+
+c     Starting loop on sub-domain
+c     ----------------------------
+
+      DO jd=1,ndomain
+        ig0=(jd-1)*ndomainsz
+        if (jd.eq.ndomain) then
+          nd=ngridmx-ig0
+        else
+          nd=ndomainsz
+        endif
+
+c    selection des points pour lesquels le shema est actif:
+
+        igwd=0
+        DO ig=ig0+1,ig0+nd
+          itest(ig)=0
+          ll=zstd(ig).gt.50.0
+          IF(ll) then
+            itest(ig)=1
+            igwd=igwd+1
+            zidx(igwd)=ig - ig0
+          ENDIF
+        ENDDO
+        IGWDIM=MAX(1,IGWD)
+
+c       Spliting input variable in sub-domain input variables
+c       ---------------------------------------------------
+
+        do l=1,nlayer+1
+          do ig = 1,nd
+           zplev(ig,l) = pplev(ig0+ig,l)
+          enddo
+        enddo
+
+        do l=1,nlayer
+          do ig = 1,nd
+            zplay(ig,l) = pplay(ig0+ig,l)
+            zt(ig,l) = pt(ig0+ig,l)
+            zu(ig,l) = pu(ig0+ig,l)
+            zv(ig,l) = pv(ig0+ig,l)
+          enddo
+        enddo
+
+
+c       Calling gravity wave and subgrid scale topo parameterization
+c       -------------------------------------------------------------
+
+        call drag_noro (nd,nlayer,ptimestep,zplay,zplev,
+     e            zstd(ig0+1),zsig(ig0+1),zgam(ig0+1),zthe(ig0+1),
+     e            igwd,igwdim,zidx,itest(ig0+1),
+     e            zt, zu, zv,
+     s            zulow(ig0+1),zvlow(ig0+1),zustr(ig0+1),zvstr(ig0+1),
+     s            zzdtgw,zzdugw,zzdvgw)
+
+
+c       Un-spliting output variable from sub-domain input variables
+c       ------------------------------------------------------------
+c       (and devide by ptimestep -> true tendancies)
+
+        do l=1,nlayer
+         do ig = 1,nd
+          pdtgw(ig0+ig,l) = zzdtgw(ig,l)/ptimestep
+          pdugw(ig0+ig,l) = zzdugw(ig,l)/ptimestep
+          pdvgw(ig0+ig,l) = zzdvgw(ig,l)/ptimestep
+         enddo
+        enddo
+
+      ENDDO         !   (boucle jd=1, ndomain)
+
+
+      return
+      end 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callkeys.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callkeys.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callkeys.h	(revision 57)
@@ -0,0 +1,52 @@
+      COMMON/callkeys/callrad,calldifv,calladj,callcond,callsoil,
+     s   season,diurnal,iradia,lwrite,calllott
+     s   ,iaervar,iddist,topdustref,callstats,calleofdump
+     s   ,callnirco2,callnlte,callthermos,callconduct,
+     s        calleuv,callmolvis,callmoldiff,thermochem
+     .   , solarcondate, thermoswater
+     .   , semi
+     .   , callemis
+     .   , callg2d
+     .   , linear
+     .   , ilwd
+     .   , ilwb
+     .   , ilwn
+     .   , ncouche
+     .   , alphan
+     .   , rayleigh
+     .   , tracer
+     .   , dustbin,active,doubleq,lifting,callddevil,scavenging
+     .   , sedimentation,iceparty,activice,water,caps
+     .   , photochem,nqchem_min
+
+      LOGICAL callrad,calldifv,calladj,callcond,callsoil,
+     s   season,diurnal,lwrite,calllott
+     s   ,callstats,calleofdump
+     s   ,callnirco2,callnlte,callthermos,callconduct,
+     s    calleuv,callmolvis,callmoldiff,thermochem,thermoswater
+
+
+      logical callemis
+      logical callg2d
+      logical linear
+
+      real topdustref
+      real semi
+      real alphan
+      real solarcondate
+
+      integer iddist
+      integer iaervar
+      integer iradia
+      integer ilwd
+      integer ilwb
+      integer ilwn
+      integer ncouche
+
+      logical rayleigh
+      logical tracer
+      integer dustbin
+      logical active,doubleq,lifting,callddevil,scavenging
+      logical sedimentation,iceparty,activice,water,caps
+      logical photochem
+      integer nqchem_min
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callradite.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callradite.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callradite.F	(revision 57)
@@ -0,0 +1,348 @@
+      SUBROUTINE callradite(icount,ngrid,nlayer,
+     $     aerosol,albedo,
+     $     emis,mu0,pplev,pplay,pt,tsurf,fract,dist_sol,igout,
+     $     dtlw,dtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw,fluxtop_sw)
+
+
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Subroutine designed to call the main canonic
+c   radiative transfer subroutine "lwmain" et "swmain"
+c   to compute radiative heating and cooling rate and
+c   radiative fluxes to the surface.
+c
+c   These calculations are only valid on the part of the atmosphere
+c   where Local Thermal Equilibrium (NLTE) is verified. In practice
+c   The calculations are only performed for the first "nlaylte"
+c   parameters (nlaylte is calculated by subroutine "nlthermeq"
+c   and stored in common "yomlw.h"
+c      
+c
+c
+c   The purpose of this subroutine is
+c      1) Make some initial calculation at first call
+c      2) Split the calculation in several sub-grid
+c        ("sub-domain") to save memory and
+c        be able run on a workstation at high resolution
+c        The sub-grid size is defined in dimradmars.h
+c       3) call "lwmain" and "swmain"
+c
+c
+c   author:   
+c   ------
+c           Francois Forget / Christophe Hourdin
+c
+c   This version modified to only calculate radiative tendencies over
+c   layers 1..NFLEV (set in dimradmars.h).  Returns zero for higher
+c   layers, if any.
+c   In other routines, nlayermx -> nflev.
+c   Routines affected: lwflux, lwi, lwmain, lwxb, lwxd, lwxn.
+c   SRL 7/2000
+c
+c   definition:
+c   ----------
+c   Here, solar band#1 is spectral interval between "long1vis" and "long2vis"
+c   set in dimradmars.h 
+c   Here, solar band#2 is spectral interval between "long2vis" and "long3vis"
+c   set in dimradmars.h 
+c
+c   input:
+c   ----- 
+c   icount                counter of call to subroutine physic by gcm
+c   ngrid                 number of gridpoint of horizontal grid
+c   nlayer                Number of layer
+c
+c   aerosol(ngrid,nlayer,naerkind)    aerosol extinction optical depth
+c                         at reference wavelength "longrefvis" set
+c                         in dimradmars.h , in each layer, for one of
+c                         the "naerkind" kind of aerosol optical properties.  
+c 
+c   albedo (ngrid,2)      hemispheric surface albedo
+c                         albedo (i,1) : mean albedo for solar band#1 
+c                                        (see below)
+c                         albedo (i,2) : mean albedo for solar band#2
+c                                        (see below)
+c   mu0(ngridmx)           cos of solar zenith angle (=1 when sun at zenith)
+c   pplay(ngrid,nlayer)    pressure (Pa) in the middle of each layer
+c   pplev(ngrid,nlayer+1)  pressure (Pa) at boundaries of each layer
+c   pt(ngrid,nlayer)       atmospheric temperature in each layer (K)
+c   tsurf(ngrid)           surface temperature (K)
+c   fract(ngridmx)         day fraction of the time interval 
+c                          =1 during the full day ; =0 during the night
+c   declin                 latitude of subsolar point
+c   dist_sol               sun-Mars distance (AU)
+c   igout                  coordinate of analysed point for debugging
+c
+c  output:
+c  -------
+c dtlw (ngrid,nlayer)       longwave (IR) heating rate (K/s)
+c dtsw(ngrid,nlayer)        shortwave (Solar) heating rate (K/s)
+c fluxsurf_lw(ngrid)        surface downward flux tota LW (thermal IR) (W.m-2)
+c fluxsurf_sw(ngrid,1)      surface downward flux SW for solar band#1 (W.m-2)
+c fluxsurf_sw(ngrid,2)      surface downward flux SW for solar band#2 (W.m-2)
+c
+c fluxtop_lw(ngrid)         outgoing upward flux tota LW (thermal IR) (W.m-2)
+c fluxtop_sw(ngrid,1)       outgoing upward flux SW for solar band#1 (W.m-2)
+c fluxtop_sw(ngrid,2)       outgoing upward flux SW for solar band#2 (W.m-2)
+
+c=======================================================================
+c
+c    Declarations :
+c    -------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "yomlw.h"
+
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER Icount        
+      INTEGER ngrid,nlayer  
+      INTEGER igout
+
+      REAL aerosol(ngrid,nlayer,naerkind)
+      REAL albedo(ngrid,2),emis(ngrid)
+
+      REAL pplev(ngrid,nlayer+1),pplay(ngrid,nlayer)
+      REAL pt(ngrid,nlayer)
+      REAL tsurf(ngrid)
+      REAL dist_sol,mu0(ngrid),fract(ngrid)
+      REAL dtlw(ngridmx,nlayermx),dtsw(ngridmx,nlayermx)
+      REAL fluxsurf_lw(ngridmx), fluxtop_lw(ngridmx)
+      REAL fluxsurf_sw(ngridmx,2), fluxtop_sw(ngridmx,2)
+      REAL flux(ngridmx,6)
+
+
+c
+c    Local variables :
+c    -----------------
+
+      INTEGER l,ig, n
+      INTEGER jd,j,ig0,nd
+
+      real  cste_mars ! solar constant on Mars (Wm-2)
+      REAL ptlev(ngridmx,nlayermx+1)
+
+
+      INTEGER ndomain
+      parameter (ndomain = (ngridmx-1) / ndomainsz + 1)
+
+c     Thermal IR net radiative budget (W m-2)
+      real znetrad(ndomainsz,nflev) 
+
+      real zfluxd_sw(ndomainsz,nflev+1,2)
+      real zfluxu_sw(ndomainsz,nflev+1,2)
+
+
+      REAL zplev(ndomainsz,nflev+1)
+      REAL zztlev(ndomainsz,nflev+1)
+      REAL zplay(ndomainsz,nflev)
+      REAL zt(ndomainsz,nflev)
+      REAL zaerosol(ndomainsz,nflev,naerkind)
+      REAL zalbedo(ndomainsz,2)
+      REAL zdp(ndomainsz,nflev)
+      REAL zdt0(ndomainsz)
+
+      REAL zzdtlw(ndomainsz,nflev)
+      REAL zzdtsw(ndomainsz,nflev)
+      REAL zzflux(ndomainsz,6)
+      real zrmuz
+
+
+c   local saved variables
+c   ---------------------
+
+      real pview(ngridmx)
+      save pview
+      
+      real zco2   ! volume fraction of CO2 in Mars atmosphere
+      DATA zco2/0.95/
+      SAVE zco2
+
+      LOGICAL firstcall
+      DATA firstcall/.true./
+      SAVE firstcall
+
+c----------------------------------------------------------------------
+
+c     Initialisation
+c     --------------
+
+      IF (firstcall) THEN
+         DO ig=1,ngrid
+            pview(ig)=1.66     ! cosecant of viewing angle
+         ENDDO
+         gcp = g/cpp
+         CALL SUAER
+         CALL SULW
+
+         write(*,*) 'Splitting radiative calculations: ',
+     $              ' ngridmx,ngrid,ndomainsz,ndomain',
+     $                ngridmx,ngrid,ndomainsz,ndomain
+         if (ngridmx .EQ. 1) then
+           if (ndomainsz .NE. 1) then
+             print*
+             print*,'ATTENTION !!!'
+             print*,'pour tourner en 1D, '
+             print*,'fixer ndomainsz=1 dans phymars/dimradmars.h'
+             print*
+             call exit(1)
+           endif
+         endif
+         firstcall=.false.
+      END IF
+
+c     Starting loop on sub-domain
+c     ----------------------------
+
+      DO jd=1,ndomain
+        ig0=(jd-1)*ndomainsz
+        if (jd.eq.ndomain) then
+         nd=ngridmx-ig0
+        else
+         nd=ndomainsz
+        endif
+        
+
+c       Spliting input variable in sub-domain input variables
+c       ---------------------------------------------------
+        do l=1,nlaylte+1
+         do ig = 1,nd
+          zplev(ig,l) = pplev(ig0+ig,l)
+         enddo
+        enddo
+
+        do l=1,nlaylte
+         do ig = 1,nd
+          zplay(ig,l) = pplay(ig0+ig,l)
+          zt(ig,l) = pt(ig0+ig,l)
+
+c         Thickness of each layer (Pa) :
+          zdp(ig,l)= pplev(ig0+ig,l) - pplev(ig0+ig,l+1)
+         enddo
+        enddo
+
+        do n=1,naerkind
+          do l=1,nlaylte
+            do ig=1,nd
+              zaerosol(ig,l,n) = aerosol(ig0+ig,l,n)
+            enddo
+          enddo
+        enddo
+
+        do j=1,2
+          do ig = 1,nd
+           zalbedo(ig,j) = albedo(ig0+ig,j)
+          enddo
+        enddo
+
+c       Intermediate  levels: (computing tlev)
+c       ---------------------------------------
+c       Extrapolation for the air temperature above the surface
+        DO ig=1,nd
+              zztlev(ig,1)=zt(ig,1)+
+     s        (zplev(ig,1)-zplay(ig,1))*
+     s        (zt(ig,1)-zt(ig,2))/(zplay(ig,1)-zplay(ig,2))
+
+              zdt0(ig) = tsurf(ig0+ig) - zztlev(ig,1)
+        ENDDO
+
+        DO l=2,nlaylte
+         DO ig=1,nd
+               zztlev(ig,l)=0.5*(zt(ig,l-1)+zt(ig,l))
+         ENDDO
+        ENDDO
+
+        DO ig=1,nd
+           zztlev(ig,nlaylte+1)=zt(ig,nlaylte)
+        ENDDO
+
+
+c       Longwave ("lw") radiative transfer (= thermal infrared)
+c       -------------------------------------------------------
+        call lwmain (ig0,icount,nd,nflev
+     .        ,zdp,zdt0,emis(ig0+1),zplev,zztlev,zt
+     .        ,zaerosol,zzdtlw
+     .        ,fluxsurf_lw(ig0+1),fluxtop_lw(ig0+1)
+     .        ,znetrad)
+
+c       Shortwave ("sw") radiative transfer (= solar radiation)
+c       -------------------------------------------------------
+c          Mars solar constant (W m-2)
+c          1370 W.m-2 is the solar constant at 1 AU.
+           cste_mars=1370./(dist_sol*dist_sol)
+
+           call swmain ( nd, nflev, 
+     S     cste_mars, zalbedo, 
+     S     mu0(ig0+1), zdp, zplev, zaerosol, fract(ig0+1),
+     S     zzdtsw, zfluxd_sw, zfluxu_sw)
+
+c       Un-spliting output variable from sub-domain input variables
+c       ------------------------------------------------------------
+
+        do l=1,nlaylte
+         do ig = 1,nd
+          dtlw(ig0+ig,l) = zzdtlw(ig,l)
+          dtsw(ig0+ig,l) = zzdtsw(ig,l)
+         enddo
+        enddo
+
+        do l=1,nlaylte+1
+         do ig = 1,nd
+          ptlev(ig0+ig,l) = zztlev(ig,l)
+         enddo
+        enddo
+
+        do ig = 1,nd
+          fluxsurf_sw(ig0+ig,1) = zfluxd_sw(ig,1,1)
+          fluxsurf_sw(ig0+ig,2) = zfluxd_sw(ig,1,2)
+          fluxtop_sw(ig0+ig,1) = zfluxu_sw(ig,nlaylte+1,1)
+          fluxtop_sw(ig0+ig,2) = zfluxu_sw(ig,nlaylte+1,2)
+        enddo
+
+
+      ENDDO         !   (boucle jd=1, ndomain)
+
+
+c     Zero tendencies for any remaining layers between nlaylte and nlayer
+      if (nlayer.gt.nlaylte) then
+         do l = nlaylte+1, nlayer
+            do ig = 1, ngrid
+               dtlw(ig, l) = 0.
+               dtsw(ig, l) = 0.
+            enddo
+         enddo
+      endif
+        
+
+c     Output for debugging if lwrite=T
+c     --------------------------------
+c     Write all nlayer layers, even though only nlaylte layers may have
+c     non-zero tendencies.
+
+         IF(lwrite) THEN
+            PRINT*,'Diagnotique for the radiation'
+            PRINT*,'albedo, emissiv, mu0,fract,fluxsurf_lw,fluxsurf_sw'
+            PRINT*,albedo(igout,1),emis(igout),mu0(igout),
+     s           fract(igout), fluxsurf_lw(igout),
+     $     fluxsurf_sw(igout,1)+fluxsurf_sw(igout,2)
+            PRINT*,'Tlay Tlev Play Plev dT/dt SW dT/dt LW (K/s)'
+            PRINT*,'daysec',daysec
+            DO l=1,nlayer
+               PRINT*,pt(igout,l),ptlev(igout,l),
+     s         pplay(igout,l),pplev(igout,l),
+     s         dtsw(igout,l),dtlw(igout,l)
+            ENDDO
+         ENDIF
+
+
+      return
+      end 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim.F	(revision 57)
@@ -0,0 +1,144 @@
+      SUBROUTINE callsedim(ngrid,nlay, ptimestep,
+     $                pplev,zlev, pt,
+     &                pq, pdqfi, pdqsed,pdqs_sed,nq)
+      IMPLICIT NONE
+
+c=======================================================================
+c      Sedimentation of the  Martian aerosols
+c      depending on their density and radius
+c
+c      F.Forget 1999
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "tracer.h"
+#include "callkeys.h"
+
+#include "fisice.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL ptimestep            ! pas de temps physique (s)
+      REAL pplev(ngrid,nlay+1)   ! pression aux inter-couches (Pa)
+      REAL pt(ngrid,nlay)    ! temperature au centre des couches (K)
+      REAL zlev(ngrid,nlay+1) ! altitude at layer boundaries
+
+
+c    Traceurs :
+      integer nq             ! nombre de traceurs
+      real pq(ngrid,nlay,nq)  ! traceur (kg/kg)
+      real pdqfi(ngrid,nlay,nq)  ! tendance avant sedimentation (kg/kg.s-1)
+      real pdqsed(ngrid,nlay,nq) ! tendande due a la sedimentation (kg/kg.s-1)
+      real pdqs_sed(ngrid,nq)    ! flux en surface (kg.m-2.s-1)
+      
+c   local:
+c   ------
+
+      INTEGER l,ig, iq
+
+      real zqi(ngridmx,nlayermx)
+      real masse (ngridmx,nlayermx)
+      real epaisseur (ngridmx,nlayermx)
+      real wq(ngridmx,nlayermx+1) 
+c      real dens(ngridmx,nlayermx) ! Mean density of the ice part. accounting for dust core
+      real rfall(ngridmx,nlayermx)
+
+
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall/.true./
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+         IF(ngrid.NE.ngridmx) THEN
+            PRINT*,'STOP dans coefdifv'
+            PRINT*,'probleme de dimensions :'
+            PRINT*,'ngrid  =',ngrid
+            PRINT*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+         firstcall=.false.
+      ENDIF
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+c
+c     Calcul preliminaires  de caracteristiques des couches
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c    Masse (kg.m-2), epaisseur(m), temps de traversee (s)  etc...
+
+
+      do  l=1,nlay
+        do ig=1, ngrid
+          masse(ig,l)=(pplev(ig,l) - pplev(ig,l+1)) /g 
+          epaisseur(ig,l)= zlev(ig,l+1) - zlev(ig,l)
+        end do
+      end do
+
+      do iq=1, nq
+
+        if(radius(iq).gt.1.e-9) then   ! no sedim for gaz (defined by radius=0)
+
+c         On "update" la valeur de q apres les autres parametrisations
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+          do l=1,nlay
+            do ig=1,ngrid
+              zqi(ig,l)=pq(ig,l,iq)+pdqfi(ig,l,iq)*ptimestep
+              if (iceparty.and.iq.eq.nq-1) then
+c               On affecte un rayon moyen aux poussieres a chaque altitude du type :
+c               r(z)=r0*exp(-z/H) avec r0=0.8 micron et H=18 km.
+c               ''''''''''''''''''''''''''''''''''''''''''''''''
+                rfall(ig,l)=max( rice(ig,l)*1.5,rdust(ig,l) )
+c modif FranckMM pour ameliorer cycle H2O: rfall= 20 microns
+                rfall(ig,l)=min(rfall(ig,l),1.e-4)
+!mars commente pour l'instant               rfall(ig,l)=20.e-6
+                
+              endif
+            enddo
+          enddo
+
+c         Calcul du transport par sedimentation pour chaque traceur
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(iceparty.and.iq.eq.nq-1) then
+            call newsedim(ngrid,nlay,ngrid*nlay,ptimestep,
+     &      pplev,masse,epaisseur,pt,rfall,rho_q(iq),zqi,wq)
+          else
+            call newsedim(ngrid,nlay,1,ptimestep,
+     &      pplev,masse,epaisseur,pt,radius(iq),rho_q(iq),zqi,wq)
+          endif
+
+c         Calcul des tendances
+c         ~~~~~~~~~~~~~~~~~~~~
+          do ig=1,ngrid 
+            if(iceparty.and.iq.eq.nq-1) then
+                pdqs_sed(ig,nq) = wq(ig,1)/ptimestep 
+            else
+                pdqs_sed(ig,iq) = wq(ig,1)/ptimestep 
+            endif
+          end do
+          DO l = 1, nlay
+            DO ig=1,ngrid
+c	      zqi(ig,l)=max(zqi(ig,l), 1.e-10)
+              pdqsed(ig,l,iq)=(zqi(ig,l)-
+     $        (pq(ig,l,iq) + pdqfi(ig,l,iq)*ptimestep))/ptimestep
+            ENDDO
+          ENDDO
+        endif
+      enddo
+ 
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim2q.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim2q.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/callsedim2q.F	(revision 57)
@@ -0,0 +1,294 @@
+      SUBROUTINE callsedim2q(ngrid,nlay, ptimestep,
+     $                pplev,zlev, pt,
+     &                pq, pdqfi, pdqsed,pdqs_sed,nq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c      Sedimentation of the  Martian dust 
+c      using method with mass (iq=1) and number(iq=2) mixing ratio
+c
+c      F.Forget 1999
+c
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "tracer.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL ptimestep             ! pas de temps physique (s)
+      REAL pplev(ngrid,nlay+1)   ! pression aux inter-couches (Pa)
+      REAL pt(ngrid,nlay)        ! temperature au centre des couches (K)
+      REAL zlev(ngrid,nlay+1)    ! altitude at layer boundaries
+
+
+c    Traceurs :
+      integer nq                 ! nombre de traceurs
+      real pq(ngrid,nlay,nq)     ! traceur (kg/kg)
+      real pdqfi(ngrid,nlay,nq)  ! tendance avant sedimentation (kg/kg.s-1)
+      real pdqsed(ngrid,nlay,nq) ! tendande due a la sedimentation (kg/kg.s-1)
+      real pdqs_sed(ngrid,nq)    ! flux en surface (kg.m-2.s-1)
+      
+c   local:
+c   ------
+
+      INTEGER l,ig
+
+      LOGICAL firstcall
+      SAVE firstcall
+
+c    Traceurs :
+c    ~~~~~~~~ 
+      INTEGER iq
+      real zq(ngridmx,nlayermx,2)
+      real masse(ngridmx,nlayermx)      ! Layer mass (kg.m-2)
+      real epaisseur(ngridmx,nlayermx)  ! Layer thickness (m)
+      real wq(ngridmx,nlayermx+1)       ! moved tracer mass (kg.m-2)
+      real r0(ngridmx,nlayermx)         ! geometric mean radius (m)
+
+
+c     Discretisation en taille:
+c     ~~~~~~~~~~~~~~
+c       1) Discretisation pour representer la variation de Vitesse de chute
+      integer nr,ir
+      parameter (nr=7)   ! nombre de rayon pour le calcul du transport
+      real rd(nr),qr(ngridmx,nlayermx,nr)
+      real rdi(nr+1)    ! extreme and intermediate radii
+      real Sq(ngridmx,nlayermx)
+      real rdmin,rdmax,rdimin,rdimax
+      data rdmin/1.e-7/
+      data rdmax/30.e-6/
+      data rdimin/1.e-10/
+      data rdimax/1e-4/
+      save rd, rdi
+
+c       2) Sous discretisation pour bien integrer la loi lognormale
+c          (calcul de q pour chaque gamme de rayon rd)
+
+      integer nint, iint   
+      parameter (nint=4)  ! nombre de point entre chaque rayon rdi
+      real rr(nint,nr)
+      save rr
+      
+      real reff(ngridmx,nlayermx,2)  ! for diagnostic only
+      
+
+
+
+      DATA firstcall/.true./
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+         IF(ngrid.NE.ngridmx) THEN
+            Print*,'STOP dans coefdifv'
+            Print*,'probleme de dimensions :'
+            Print*,'ngrid  =',ngrid
+            Print*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+         firstcall=.false.
+ 
+         do ir=1,nr
+             rd(ir)= rdmin*(rdmax/rdmin)**(float(ir-1)/float(nr-1))
+c            rd(ir) = rdmin + (float(ir-1)/float(nr-1))*(rdmax-rdmin)
+         end do
+         rdi(1)=rdimin
+         do ir=2,nr
+           rdi(ir)= sqrt(rd(ir-1)*rd(ir))
+         end do
+         rdi(nr+1)=rdimax
+
+         do ir=1,nr
+           do iint=1,nint
+             rr(iint,ir)=
+     &       rdi(ir)*(rdi(ir+1)/rdi(ir))**(float(iint-1)/float(nint-1))
+c             write(*,*) rr(iint,ir)
+           end do
+         end do
+      ENDIF
+
+
+
+
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+
+c    On "update" la valeur de q apres les autres parametrisations
+c    ~~~~~~~~~~~~~~~~~~~~~~~~~~
+      do iq=1,2
+        do l=1,nlay
+          do ig=1,ngrid
+            zq(ig,l,iq)=pq(ig,l,iq)+pdqfi(ig,l,iq)*ptimestep
+          enddo
+        enddo
+      enddo
+
+
+c    Calcul preliminaires  de caracteristiques des couches
+c    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c    Masse (kg.m-2), epaisseur(m), temps de traversee (s)  etc...
+
+      do  l=1,nlay
+        do ig=1, ngrid
+          masse(ig,l)=(pplev(ig,l) - pplev(ig,l+1)) /g
+          epaisseur(ig,l)= zlev(ig,l+1) - zlev(ig,l)
+        end do
+      end do
+
+
+c     Calcul de la distribution de taille
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      do  l=1,nlay
+         do ig=1, ngrid
+              r0(ig,l)=
+     &        (r3n_q*zq(ig,l,1)/max(zq(ig,l,min(2,nq)),0.01))**(1./3.)
+              r0(ig,l)=min(max(r0(ig,l),1.e-10),500.e-6)
+         end do
+      end do
+
+      DO iq=1,2  ! LOOP on Mass (iq=1) then Number(iq=2) mixing ratio
+
+c        Calcul du rapport de melange pour les nir tailles considerees
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          call zerophys(ngridmx*nlayermx, Sq)
+          do ir=1,nr
+            do l=1,nlay
+              do ig=1,ngrid
+c                **************** nouvelle methode :
+c                Calcul de q pour chaque gamme de rayon rd
+c                Sous discretisation pour bien integrer la loi lognormale
+c                (Methode des trapezes)
+                 qr(ig,l,ir)=0.5*(rr(2,ir)-rr(1,ir))*
+     &             (rr(1,ir)**(5-3*iq))*
+     &             exp(-(log(rr(1,ir)/r0(ig,l)))**2/(2*varian**2))
+                 do iint=2,nint-1
+                   qr(ig,l,ir)=qr(ig,l,ir) +
+     &             0.5*(rr(iint+1,ir)-rr(iint-1,ir))*
+     &             (rr(iint,ir)**(5-3*iq))*
+     &             exp(-(log(rr(iint,ir)/r0(ig,l)))**2/(2*varian**2))
+                 end do
+                   qr(ig,l,ir)=qr(ig,l,ir) +
+     &             0.5*(rr(nint,ir)-rr(nint-1,ir))*
+     &             (rr(nint,ir)**(5-3*iq))*
+     &             exp(-(log(rr(nint,ir)/r0(ig,l)))**2/(2*varian**2))
+
+c                **************** Methode simple BUGGEE
+c                qr(ig,l,ir)=(rd(ir)**(5-3*iq))*
+c    &           exp( -(log(rd(ir)/r0(ig,l)))**2 / (2*varian**2) )
+c                ******************************
+                 Sq(ig,l)=Sq(ig,l)+qr(ig,l,ir) 
+              enddo
+            enddo
+          enddo
+          do ir=1,nr
+            do l=1,nlay
+              do ig=1,ngrid
+                 qr(ig,l,ir)= zq(ig,l,iq)* qr(ig,l,ir)/Sq(ig,l)
+              enddo
+            enddo
+c          write(123,*) rd(ir)*1.e6, qr(1,10,ir)
+          enddo
+
+c         Calcul du transport par sedimentation pour chaque traceur
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+          call zerophys(ngridmx*nlayermx,zq(1,1,iq))
+          call zerophys(ngridmx*nlayermx,pdqs_sed(1,iq))
+
+c         write(*,*)
+c         if(iq.eq.1) write(*,*) '5 fois  wq(6), wq(7), q(6)'
+          
+          do ir=1,nr
+             call newsedim(ngrid,nlay,1,ptimestep,
+     &       pplev,masse,epaisseur,pt,rd(ir),rho_dust,qr(1,1,ir),wq)
+
+c            Calcul des tendances
+c            ~~~~~~~~~~~~~~~~~~~~
+             do ig=1,ngrid
+               pdqs_sed(ig,iq) = pdqs_sed(ig,iq) + wq(ig,1)/ptimestep
+             end do
+             DO l = 1, nlay
+               DO ig=1,ngrid
+                 zq(ig,l,iq)=zq(ig,l,iq)+qr(ig,l,ir)
+               ENDDO
+             ENDDO
+c         if(iq.eq.1) write(*,*) 'callsed: wq(6), wq(7), q(6)',
+c    &               wq(1,6),wq(1,7),qr(1,6,ir)
+
+c               if(iq.eq.1)write(*,*)'R=', rd(ir)*1.e6
+c               write(*,*)
+          enddo
+
+          do l = 1, nlay
+            do ig=1,ngrid
+              pdqsed(ig,l,iq)=(zq(ig,l,iq)-
+     $        (pq(ig,l,iq) + pdqfi(ig,l,iq)*ptimestep))/ptimestep
+            enddo
+          enddo
+
+c     ***** Diagnostique *****************
+c         call zerophys(ngridmx*nlayermx,reff(1,1,iq))
+c         do ir=1,nr
+c           do l = 1, nlay
+c             do ig=1,ngrid
+c              if(iq.eq.1) then 
+c               reff(ig,l,iq)=reff(ig,l,iq) + qr(ig,l,ir)/rd(ir)
+c              else
+c               reff(ig,l,iq)=reff(ig,l,iq) + qr(ig,l,ir)*log(rd(ir))
+c              endif
+c             enddo
+c           enddo
+c         enddo
+c         do l = 1, nlay
+c           do ig=1,ngrid
+c            if(iq.eq.1) then 
+c             reff(ig,l,iq)=zq(ig,l,iq)/reff(ig,l,iq)
+c            else
+c             reff(ig,l,iq)=exp(reff(ig,l,iq)/zq(ig,l,iq))
+c            endif
+c           enddo
+c         enddo
+c     **** FIN Diagnostique *****************
+
+      enddo  ! end loop on iq=1,2
+
+
+
+c ********************************************
+c     Diagnostique
+c     if(ngrid.eq.1) then
+c      do  l=1,nlay
+c       do ig=1, ngrid
+c         r0(ig,l)=
+c    &    (r3n_q*zq(ig,l,1)/max(zq(ig,l,min(2,nq)),0.01))**(1./3.)
+c         r0(ig,l)=min(max(r0(ig,l),1.e-10),500.e-6)
+c
+c         write(*,*)'l,r0, r02 ', l, r0(ig,l),reff(ig,l,1)*0.3626
+c    &    ,reff(ig,l,2)
+c    &    ,r0(ig,l)/(reff(ig,l,1)*0.3626) 
+c
+c       end do
+c      end do
+c      CALL writeg1d(ngrid,nlay,r0,'r0','m')
+c     end if
+c ********************************************
+
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/co2snow.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/co2snow.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/co2snow.F	(revision 57)
@@ -0,0 +1,140 @@
+      SUBROUTINE co2snow (ngrid,nlayer,ptimestep,emisref,condsub,pplev,
+     &        pcondicea,pcondices,pfallice,pemisurf)
+
+       IMPLICIT NONE
+
+c=======================================================================
+c     Program for simulate the impact of the CO2 snow fall on
+c     the surface infrared emission (emissivity)  and on 
+c     the airborne dust
+c     F.Forget 1996
+c=======================================================================
+
+c Declarations
+c ------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "surfdat.h"
+#include "callkeys.h"
+
+c     input
+c     -----
+
+      INTEGER ngrid,nlayer
+      REAL ptimestep , emisref(ngrid) ! grd or ice  emissivity without snow
+      logical condsub(ngrid)
+
+      REAL pplev(ngrid,nlayer+1)
+      REAL pcondicea(ngrid,nlayer), pcondices(ngrid)
+      REAL pfallice(ngrid,nlayer+1)
+
+c     output
+c     ------
+
+      REAL pemisurf(ngrid)
+
+c     local
+c     -----
+      integer ig , l , icap
+
+      REAL zdemisurf ,dtemis
+      REAL sumdaer
+
+c     saved
+c     -----
+      REAL Kscat(2), scaveng
+      LOGICAL firstcall
+      SAVE firstcall
+      save Kscat , scaveng
+      DATA firstcall/.true./
+
+c --------------
+c Initialisation
+c --------------
+
+      if (firstcall) then
+
+c   Kscat : coefficient for decreasing the surface emissivity
+c           =(0.001/3.)*alpha/iceradius ,
+c           with 0.3< alpha < 0.6, set to 0.45 (coeff from emis = f (tau))
+c           and iceradius the mean radius of the
+c           scaterring particles  (200.e-6<iceradius<10.e-6)
+
+            Kscat(1)=(0.001/3.)*0.45/iceradius(1)
+            Kscat(2)=(0.001/3.)*0.45/iceradius(2)
+
+c          Scavenging Ratio (dust concentration in the air / in the snow)
+           scaveng = 100.0
+           
+c          Collision Scavenging coefficient  (m2.kg-1)
+c          Csca  = 2.3  ! not used yet !!!!!!!!!!!
+           firstcall = .false.
+
+      end if
+
+
+c     LOOP on grid points
+c     -------------------
+      do ig=1,ngrid 
+         if (condsub(ig)) then
+
+c         IF (scavenging) then
+c          Airborne Dust 
+c          -------------
+c          sumdaer=0.
+c          do l=nlayer, 1, -1
+c             pdaerosol(ig,l)= -paerosol(ig,l,1)*
+c    &              (1-exp(-scaveng*pcondicea(ig,l)*ptimestep*g/
+c    &               (pplev(ig,l)-pplev(ig,l+1))))/ptimestep  
+
+c    &           - Csca*paerosol(ig,l,1) ! Scavenging by collision
+c    &           * 0.5*(pfallice(ig,l)) ! not included
+
+c             test to avoid releasing to much dust when subliming:
+c             if(pdaerosol(ig,l).gt.-sumdaer)pdaerosol(ig,l)=-sumdaer 
+c             sumdaer=sumdaer + pdaerosol(ig,l)
+
+c            if (-pdaerosol(ig,l)*ptimestep.gt.paerosol(ig,l,1)) then
+c                write(*,*) 'ds co2snow: aerosol < 0.0 !!!'
+c                write(*,*) 'ig =' , ig
+c            end if
+c          end do
+c         END IF
+
+c          Surface emissivity
+c          ------------------
+c   dtemis: Time scale for increasing the ice emissivity
+
+           IF(ig.GT.ngrid/2+1) THEN
+              icap=2
+           ELSE
+              icap=1
+           ENDIF
+
+           zdemisurf = 
+     &    (emisref(ig)-pemisurf(ig))/(dtemisice(icap)*daysec) 
+c Using directly the diferential equation:
+c    &       -Kscat(icap)*emisref(ig)*
+c    &      (pemisurf(ig)/emisref(ig))**4 *pfallice(ig,1) 
+c Using an integrated form for numerical safety instead
+     & +(emisref(ig)* ((pemisurf(ig)/emisref(ig))**(-3)+3.*Kscat(icap)*
+     & pfallice(ig,1)*ptimestep)**(-1/3.) -pemisurf(ig))/ptimestep   
+
+
+           pemisurf(ig) = pemisurf(ig) + zdemisurf*ptimestep 
+
+           if (pemisurf(ig).lt.0.1) then
+                 write(*,*) 'ds co2snow: emis < 0.1 !!!'
+                 write(*,*) 'ig =' , ig
+                 write(*,*)'pemisurf(ig)',pemisurf(ig)
+                 write(*,*) 'zdemisurf*ptimestep',zdemisurf*ptimestep
+           end if
+         else
+           pemisurf(ig) = emisref(ig)
+         end if
+      end do
+
+      return
+      end 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comcstfi.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comcstfi.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comcstfi.h	(revision 57)
@@ -0,0 +1,7 @@
+!-----------------------------------------------------------------------
+! INCLUDE "comcstfi.h"
+
+      common/comcstfi/pi,rad,g,r,cpp,rcp,dtphys,daysec,mugaz,omeg
+
+      real pi,rad,g,r,cpp,rcp,dtphys,daysec,mugaz,omeg
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comdiurn.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comdiurn.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comdiurn.h	(revision 57)
@@ -0,0 +1,5 @@
+      COMMON/comdiurn/ldiurn,
+     s     sinlon(ngridmx),coslon(ngridmx),
+     s     sinlat(ngridmx),coslat(ngridmx)
+      REAL sinlon,coslon,sinlat,coslat
+      LOGICAL ldiurn
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comg1d.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comg1d.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comg1d.h	(revision 57)
@@ -0,0 +1,59 @@
+c.......................................................................
+c  le COMMON pour GRADS-1D
+c  (Utilise pour les sorties format Grads dans la version 1D du modele)
+c
+c  on peut se dire : "on ne sauvera pas plus de 1000 variables ... hein ?"
+c
+      INTEGER g1d_nvarmx
+      PARAMETER(g1d_nvarmx=1000)
+c
+c         * g1d_nlayer     ---> nombre de couches verticales
+c         * g1d_nomfich    ---> nom du fichier grads
+c         * g1d_unitfich   ---> code du fichier grads
+c         * g1d_nomctl     ---> nom du fichier ctl
+c         * g1d_unitctl    ---> code du fichier ctl
+c         * g1d_premier    ---> variable logique pour dire si le fichier
+c                               est deja ouvert
+c         * g1d_irec       ---> indice de derniere ecriture
+c         * g1d_nvar       ---> nombre de variables deja definies a la
+c                               derniere ecriture
+c         * g1d_nomvar     ---> noms des vecteurs existants
+c         * g1d_dimvar     ---> taille des vecteurs
+c         * g1d_titrevar   ---> titres des vecteurs
+c         * g1d_tmp1       ---> caractere 
+c         * g1d_tmp2       ---> caractere 
+c
+      INTEGER g1d_nlayer
+      CHARACTER*100 g1d_nomfich
+      INTEGER g1d_unitfich
+      CHARACTER*100 g1d_nomctl
+      INTEGER g1d_unitctl
+      LOGICAL g1d_premier
+      LOGICAL g2d_premier
+      INTEGER g1d_irec
+      INTEGER g2d_irec
+      INTEGER g2d_appel
+      INTEGER g1d_nvar
+      CHARACTER*100 g1d_nomvar
+      INTEGER g1d_dimvar
+      CHARACTER*100 g1d_titrevar
+      CHARACTER*100 g1d_tmp1,g1d_tmp2
+c
+      COMMON/COMG1DI/g1d_nlayer
+     &             ,g1d_unitfich
+     &             ,g1d_unitctl
+     &             ,g1d_irec
+     &             ,g2d_irec
+     &             ,g2d_appel
+     &             ,g1d_nvar
+      COMMON/COMG1DC/g1d_dimvar(0:g1d_nvarmx)
+     &             ,g1d_nomfich
+     &             ,g1d_nomctl
+     &             ,g1d_nomvar(0:g1d_nvarmx)
+     &             ,g1d_titrevar(0:g1d_nvarmx)
+     &             ,g1d_tmp1
+     &             ,g1d_tmp2
+      COMMON/COMG1DL/g1d_premier
+     &             ,g2d_premier
+c
+c.......................................................................
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comgeomfi.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comgeomfi.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comgeomfi.h	(revision 57)
@@ -0,0 +1,4 @@
+      COMMON/comgeomfi1/long(ngridmx),lati(ngridmx),area(ngridmx)
+      COMMON/comgeomfi2/ totarea
+
+      REAL long,lati,area,totarea
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comorbit.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comorbit.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comorbit.h	(revision 57)
@@ -0,0 +1,12 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'comorbit.h'
+
+      COMMON/comorbit/aphelie,periheli,year_day,
+     $       peri_day,timeperi,obliquit,
+     $       e_elips,p_elips,unitastr,pi
+
+      REAL aphelie,periheli,year_day,
+     $  peri_day,timeperi,obliquit,
+     $  e_elips,p_elips,unitastr,pi
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comsaison.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comsaison.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/comsaison.h	(revision 57)
@@ -0,0 +1,11 @@
+c-----------------------------------------------------------------------
+c   INCLUDE saison.h
+
+      COMMON/saison/callsais,isaison,dist_sol,declin,
+     $             mu0(ngridmx),fract(ngridmx)
+
+      INTEGER isaison
+      LOGICAL callsais
+      REAL dist_sol,declin,mu0,fract
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/convadj.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/convadj.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/convadj.F	(revision 57)
@@ -0,0 +1,350 @@
+      SUBROUTINE convadj(ngrid,nlay,nq,ptimestep,
+     S                   pplay,pplev,ppopsk,
+     $                   pu,pv,ph,pq,
+     $                   pdufi,pdvfi,pdhfi,pdqfi,
+     $                   pduadj,pdvadj,pdhadj,
+     $                   pdqadj)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   ajustement convectif sec
+c   on ajoute les tendances pdhfi au profil pdh avant l'ajustement
+c   SPECIAL VERSION : if one tracer is CO2, take into account the
+c   Molecular mass variation (e.g. when CO2 condense) to trigger
+c   convection  F. Forget 01/2005
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "tracer.h"
+
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL ptimestep
+      REAL ph(ngrid,nlay),pdhfi(ngrid,nlay),pdhadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1),ppopsk(ngrid,nlay)
+      REAL pu(ngrid,nlay),pdufi(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvfi(ngrid,nlay),pdvadj(ngrid,nlay)
+
+c    Traceurs :
+      integer nq
+      real pq(ngrid,nlay,nq), pdqfi(ngrid,nlay,nq)
+      real pdqadj(ngrid,nlay,nq)
+
+
+c   local:
+c   ------
+
+      INTEGER ig,i,l,l1,l2,jj
+      INTEGER jcnt, jadrs(ngridmx)
+
+      REAL sig(nlayermx+1),sdsig(nlayermx),dsig(nlayermx)
+      REAL zu(ngridmx,nlayermx),zv(ngridmx,nlayermx)
+      REAL zh(ngridmx,nlayermx)
+      REAL zu2(ngridmx,nlayermx),zv2(ngridmx,nlayermx)
+      REAL zh2(ngridmx,nlayermx), zhc(ngridmx,nlayermx)
+      REAL zhm,zsm,zdsm,zum,zvm,zalpha,zhmc
+      
+
+c    Traceurs :
+      INTEGER iq,ico2
+      save ico2
+      REAL zq(ngridmx,nlayermx,nqmx), zq2(ngridmx,nlayermx,nqmx)
+      REAL zqm(nqmx),zqco2m
+      real m_co2, m_noco2, A , B
+      save A, B
+c    Temporaire (for diagnostic)
+c      REAL diag_alpha(ngridmx)
+
+      real mtot1, mtot2 , mm1, mm2
+       integer l1ref, l2ref
+      LOGICAL vtest(ngridmx),down,firstcall
+      save firstcall
+      data firstcall/.true./
+
+      EXTERNAL SCOPY
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+      IF (firstcall) THEN 
+        IF(ngrid.NE.ngridmx) THEN
+           PRINT*
+           PRINT*,'STOP dans convadj'
+           PRINT*,'ngrid    =',ngrid
+           PRINT*,'ngridmx  =',ngridmx
+        ENDIF
+        ico2=0
+        if (tracer) then
+c          Prepare Special treatment if one of the tracer is CO2 gas
+           do iq=1,nqmx
+             if (noms(iq).eq."co2") then
+                ico2=iq
+                m_co2 = 44.01E-3  ! CO2 molecular mass (kg/mol)   
+                m_noco2 = 33.37E-3  ! Non condensible mol mass (kg/mol)   
+c               Compute A and B coefficient use to compute
+c               mean molecular mass Mair defined by
+c               1/Mair = q(ico2)/m_co2 + (1-q(ico2))/m_noco2
+c               1/Mair = A*q(ico2) + B
+                A =(1/m_co2 - 1/m_noco2)
+                B=1/m_noco2
+             end if
+           enddo
+           firstcall=.false.
+        endif
+      ENDIF
+
+c
+c-----------------------------------------------------------------------
+c   detection des profils a modifier:
+c   ---------------------------------
+c   si le profil est a modifier
+c   (i.e. ph(niv_sup) < ph(niv_inf) )
+c   alors le tableau "vtest" est mis a .TRUE. ;
+c   sinon, il reste a sa valeur initiale (.FALSE.)
+c   cette operation est vectorisable
+c   On en profite pour copier la valeur initiale de "ph"
+c   dans le champ de travail "zh"
+
+
+      DO l=1,nlay
+         DO ig=1,ngrid
+            zh(ig,l)=ph(ig,l)+pdhfi(ig,l)*ptimestep
+            zu(ig,l)=pu(ig,l)+pdufi(ig,l)*ptimestep
+            zv(ig,l)=pv(ig,l)+pdvfi(ig,l)*ptimestep
+         ENDDO
+      ENDDO
+
+      if(tracer) then      
+        DO iq =1, nq
+         DO l=1,nlay
+           DO ig=1,ngrid
+              zq(ig,l,iq)=pq(ig,l,iq)+pdqfi(ig,l,iq)*ptimestep
+           ENDDO
+         ENDDO
+        ENDDO
+      end if
+
+
+      CALL scopy(ngrid*nlay,zh,1,zh2,1)
+      CALL scopy(ngrid*nlay,zu,1,zu2,1)
+      CALL scopy(ngrid*nlay,zv,1,zv2,1)
+      CALL scopy(ngrid*nlay*nq,zq,1,zq2,1)
+
+      DO ig=1,ngrid
+        vtest(ig)=.FALSE.
+      ENDDO
+c
+      if (ico2.ne.0) then
+c        Special case if one of the tracer is CO2 gas
+         DO l=1,nlay
+           DO ig=1,ngrid
+             zhc(ig,l) = zh2(ig,l)*(A*zq2(ig,l,ico2)+B)
+           ENDDO
+         ENDDO
+       else
+          CALL scopy(ngrid*nlay,zh2,1,zhc,1)
+       end if
+
+       
+
+      DO l=2,nlay
+        DO ig=1,ngrid
+          IF(zhc(ig,l).LT.zhc(ig,l-1)) vtest(ig)=.TRUE.
+        ENDDO
+      ENDDO
+c
+      jcnt=0
+      DO ig=1,ngrid
+         IF(vtest(ig)) THEN
+            jcnt=jcnt+1
+            jadrs(jcnt)=ig
+         ENDIF
+      ENDDO
+
+
+c-----------------------------------------------------------------------
+c  Ajustement des "jcnt" profils instables indices par "jadrs":
+c  ------------------------------------------------------------
+c
+      DO jj = 1, jcnt   ! loop on every convective grid point
+c
+          i = jadrs(jj)
+ 
+c   Calcul des niveaux sigma sur cette colonne
+          DO l=1,nlay+1
+            sig(l)=pplev(i,l)/pplev(i,1)
+        
+          ENDDO
+         DO l=1,nlay
+            dsig(l)=sig(l)-sig(l+1)
+            sdsig(l)=ppopsk(i,l)*dsig(l)
+         ENDDO
+          l2 = 1
+c
+c      -- boucle de sondage vers le haut
+c
+cins$     Loop  vers le haut sur l2
+          DO
+c
+            l2 = l2 + 1
+            IF (l2 .GT. nlay) EXIT
+            IF (zhc(i, l2) .LT. zhc(i, l2-1)) THEN
+ 
+c          -- l2 est le niveau le plus haut de la colonne instable
+ 
+              l1 = l2 - 1
+              l  = l1
+              zsm = sdsig(l2)
+              zdsm = dsig(l2)
+              zhm = zh2(i, l2)
+              if(ico2.ne.0) zqco2m = zq2(i,l2,ico2)
+c
+c          -- boucle de sondage vers le bas
+c             Loop
+              DO
+c
+                zsm = zsm + sdsig(l)
+                zdsm = zdsm + dsig(l)
+                zhm = zhm + sdsig(l) * (zh2(i, l) - zhm) / zsm
+                if(ico2.ne.0) then
+                  zqco2m = 
+     &            zqco2m + dsig(l) * (zq2(i,l,ico2) - zqco2m) / zdsm
+                  zhmc = zhm*(A*zqco2m+B)
+                else 
+                  zhmc = zhm
+                end if
+ 
+c            -- doit on etendre la colonne vers le bas ?
+ 
+                down = .FALSE.
+                IF (l1 .NE. 1) THEN    !--  and then
+                  IF (zhmc .LT. zhc(i, l1-1)) THEN
+                    down = .TRUE.
+                  END IF
+                END IF
+ 
+                IF (down) THEN
+ 
+                  l1 = l1 - 1
+                  l  = l1
+ 
+                ELSE
+ 
+c              -- peut on etendre la colonne vers le haut ?
+ 
+                  IF (l2 .EQ. nlay) EXIT
+ 
+                  IF (zhc(i, l2+1) .GE. zhmc) EXIT
+c
+                  l2 = l2 + 1
+                  l  = l2
+c
+                END IF
+c
+cins$         End Loop
+              ENDDO
+c
+c          -- nouveau profil : constant (valeur moyenne)
+c
+              zalpha=0.
+              zum=0.
+              zvm=0.
+              do iq=1,nq
+                zqm(iq) = 0.
+              end do
+              DO l = l1, l2
+                if(ico2.ne.0) then
+                  zalpha=zalpha+
+     &            ABS(zhc(i,l)/(A+B*zqco2m) -zhm)*dsig(l)
+                else
+                  zalpha=zalpha+ABS(zh2(i,l)-zhm)*dsig(l)
+                endif
+                zh2(i, l) = zhm
+                zum=zum+dsig(l)*zu(i,l)
+                zvm=zvm+dsig(l)*zv(i,l)
+                do iq=1,nq
+                   zqm(iq) = zqm(iq)+dsig(l)*zq(i,l,iq)
+                end do
+              ENDDO
+              zalpha=zalpha/(zhm*(sig(l1)-sig(l2+1)))
+              zum=zum/(sig(l1)-sig(l2+1))
+              zvm=zvm/(sig(l1)-sig(l2+1))
+              do iq=1,nq
+                 zqm(iq) = zqm(iq)/(sig(l1)-sig(l2+1))
+              end do
+
+              IF(zalpha.GT.1.) THEN
+                 zalpha=1.
+              ELSE
+c                IF(zalpha.LT.0.) STOP
+                 IF(zalpha.LT.1.e-4) zalpha=1.e-4
+              ENDIF
+
+              DO l=l1,l2
+                 zu2(i,l)=zu2(i,l)+zalpha*(zum-zu2(i,l))
+                 zv2(i,l)=zv2(i,l)+zalpha*(zvm-zv2(i,l))
+                 do iq=1,nq
+c                  zq2(i,l,iq)=zq2(i,l,iq)+zalpha*(zqm(iq)-zq2(i,l,iq)) 
+                   zq2(i,l,iq)=zqm(iq)
+                 end do
+              ENDDO
+c              diag_alpha(i)=zalpha  !temporaire
+              if (ico2.ne.0) then
+                DO l=l1, l2
+                  zhc(i,l) = zh2(i,l)*(A*zq2(i,l,ico2)+B)
+                ENDDO
+              end if
+
+ 
+              l2 = l2 + 1
+c
+            END IF   ! fin traitement instabilité entre l1 et l2. 
+c                      On repart pour test à partir du l2 au dessus...
+          ENDDO   ! End Loop sur l2 vers le haut 
+c
+      ENDDO
+c
+      DO l=1,nlay
+        DO ig=1,ngrid
+          pdhadj(ig,l)=(zh2(ig,l)-zh(ig,l))/ptimestep
+          pduadj(ig,l)=(zu2(ig,l)-zu(ig,l))/ptimestep
+          pdvadj(ig,l)=(zv2(ig,l)-zv(ig,l))/ptimestep
+        ENDDO
+      ENDDO
+
+      if(tracer) then 
+        do iq=1, nq
+          do  l=1,nlay
+            do ig=1, ngrid
+              pdqadj(ig,l,iq)=(zq2(ig,l,iq)-zq(ig,l,iq))/ptimestep 
+            end do 
+          end do 
+        end do 
+      end if
+
+c     outpu
+      if (ngrid.eq.1) then
+         ig=1
+         iq =1 
+         write(*,*)'**** l, pq(ig,l,iq),zq(ig,l,iq),zq2(ig,l,iq)'  
+         do l=nlay,1,-1
+           write(*,*) l, pq(ig,l,iq),zq(ig,l,iq),zq2(ig,l,iq)
+         end do
+      end if
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgp.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgp.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgp.F	(revision 57)
@@ -0,0 +1,14 @@
+      FUNCTION cvmgp(x1,x2,x3)
+      IMPLICIT NONE
+
+      REAL x1,x2,x3,cvmgp
+
+      IF(x3.ge.0) then 
+        cvmgp=x1
+      ELSE
+        cvmgp=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgt.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgt.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/cvmgt.F	(revision 57)
@@ -0,0 +1,15 @@
+      FUNCTION cvmgt(x1,x2,l)
+      IMPLICIT NONE
+
+      REAL x1,x2,cvmgt
+      LOGICAL l
+
+      IF(l) then 
+        cvmgt=x1
+      ELSE
+        cvmgt=x2
+      ENDIF
+
+      RETURN
+      END
+C
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datafile.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datafile.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datafile.h	(revision 57)
@@ -0,0 +1,9 @@
+!-----------------------------------------------------------------------
+! INCLUDE datafile.h
+
+!  Address of the directory containing tables of data needed by the GCM    
+
+      character (len=100) :: datafile
+      data datafile /'/u/forget/WWW/datagcm/datafile'/
+!     data datafile /'/home/forget/datafile'/
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datareadnc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datareadnc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/datareadnc.F	(revision 57)
@@ -0,0 +1,291 @@
+c=======================================================================
+      SUBROUTINE datareadnc(relief,phisinit,alb,ith,
+     .                    zmea,zstd,zsig,zgam,zthe)
+c=======================================================================
+c
+c
+c   Author: F. Hourdin      01/1997
+c   -------
+c
+c   Object: To read data from Martian surface to use in a GCM
+c   ------                from NetCDF file "surface.nc"
+c
+c
+c   Arguments:
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c     Outputs:
+c     --------
+c
+c=======================================================================
+c   donnees ALBEDO, INERTIE THERMIQUE, RELIEF:
+c
+c       Ces donnees sont au format NetCDF dans le fichier "surface.nc"
+c
+c   360 valeurs en longitude (de -179.5 a 179.5)
+c   180 valeurs en latitudes (de 89.5 a -89.5)
+c
+c   Pour les passer au format de la grille, on utilise "interp_horiz.F"
+c
+c   Il faut donc que ces donnees soient au format grille scalaire
+c               (imold+1 jmold+1)
+c       avec passage des coordonnees de la "boite" (rlonu, rlatv)
+c
+c   On prend imd (d pour donnees!) 
+c           imd = 360 avec copie de la 1ere valeur sur la imd+1 
+c                   (rlonud de -179 a -181)
+c           jmd = 179 
+c                   (rlatvd de 89 a -89)
+c=======================================================================
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comconst.h"
+#include "netcdf.inc"
+#include "datafile.h"
+
+c=======================================================================
+c   Declarations:
+C=======================================================================
+
+      INTEGER    imd,jmd,imdp1,jmdp1
+      parameter    (imd=360,jmd=179,imdp1=361,jmdp1=180)
+
+      INTEGER    iimp1
+      parameter    (iimp1=iim+1-1/iim)
+
+      CHARACTER relief*3
+
+      REAL        zdata(imd*jmdp1)
+      REAL        zdataS(imdp1*jmdp1)
+      REAL        pfield(iimp1*jjp1)
+
+      REAL        alb(iimp1*jjp1)
+      REAL        ith(iimp1*jjp1)
+      REAL        phisinit(iimp1*jjp1)
+
+      REAL        zmea(imdp1*jmdp1)
+      REAL        zstd(imdp1*jmdp1)
+      REAL        zsig(imdp1*jmdp1)
+      REAL        zgam(imdp1*jmdp1)
+      REAL        zthe(imdp1*jmdp1)
+
+      INTEGER   lnblnk, ierr
+      EXTERNAL    lnblnk
+
+      INTEGER   unit,nvarid
+
+      INTEGER    i,j,k
+
+      INTEGER klatdat,ngridmxgdat
+      PARAMETER (klatdat=180,ngridmxgdat=360)
+
+c    on passe une grille en rlonu rlatv et im+1 jm a interp_horiz)
+
+      REAL longitude(imd),latitude(jmdp1) ! Pour lecture des donnees
+      REAL rlonud(imdp1),rlatvd(jmd)
+
+      CHARACTER*20 string
+      DIMENSION string(4)
+
+      CHARACTER*80    file
+
+#include "lmdstd.h"
+#include "fxyprim.h"
+
+      pi=2.*ASIN(1.)
+
+c=======================================================================
+c    rlonud, rlatvd
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c    Lecture NetCDF des donnees latitude et longitude
+c-----------------------------------------------------------------------
+      write(*,*) 'ouverture du fichier surface.nc'
+
+      ierr = NF_OPEN (datafile(1:lnblnk(datafile))//'/surface.nc',
+     &  NF_NOWRITE,unit)
+      IF (ierr.NE.NF_NOERR) THEN
+        write(*,*)'Error : cannot open file surface.nc '
+        write(*,*)'(in phymars/datareadnc.F)'
+        write(*,*)'It should be in :',datafile(1:lnblnk(datafile)),'/'
+        write(*,*)'1) You can change this directory address in '
+        write(*,*)'   file phymars/datafile.h'
+        write(*,*)'2) If necessary surface.nc (and other datafiles)'
+        write(*,*)'   can be obtained online on:'
+        write(*,*)' http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+        CALL ABORT
+      ENDIF
+
+c
+c Lecture des latitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (unit, "latitude", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, latitude)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, latitude)
+#endif
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (unit, "longitude", nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, longitude)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, longitude)
+#endif
+
+c-----------------------------------------------------------------------
+c    Passage au format boites scalaires
+c-----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c       longitude(imd)        -->      rlonud(imdp1) 
+c-----------------------------------------------------------------------
+
+c Passage en coordonnees boites scalaires et en radian
+      do i=1,imd 
+          rlonud(i)=(longitude(i)+.5)*pi/180.
+      enddo
+
+c Repetition de la valeur im+1
+      rlonud(imdp1)=rlonud(1) + 2*pi
+
+c-----------------------------------------------------------------------
+c        latitude(jmdp1)         -->        rlonvd(jmd)
+c-----------------------------------------------------------------------
+
+c Passage en coordonnees boites scalaires et en radian
+      do j=1,jmd 
+          rlatvd(j)=(latitude(j)-.5)*pi/180.
+      enddo
+
+c=======================================================================
+c   lecture NetCDF de albedo, thermal, relief, zdtm (pour francois Lott)
+c=======================================================================
+
+      string(1) = 'albedo'
+      string(2) = 'thermal'
+      if (relief.ne.'pla') then
+        write(*,*) ' La topographie est celle de MOLA'
+        relief = 'MOL'
+          string(3) = 'z'//relief
+      else
+          string(3) = 'zMOL'  ! pour qu''il lise qqchose sur le fichier
+                            ! remise a 0 derriere
+      endif
+      string(4) = 'zMOL'    ! lecture pour calcul topog. sous-maille
+ 
+
+      DO k=1,4
+          write(*,*) 'string',k,string(k)
+          
+c-----------------------------------------------------------------------
+c    initialisation
+c-----------------------------------------------------------------------
+      call initial0(iimp1*jjp1,pfield)
+      call initial0(imd*jmdp1,zdata)
+      call initial0(imdp1*jmdp1,zdataS)
+
+c-----------------------------------------------------------------------
+c    Lecture NetCDF  
+c-----------------------------------------------------------------------
+
+      ierr = NF_INQ_VARID (unit, string(k), nvarid)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(unit, nvarid, zdata)
+#else
+      ierr = NF_GET_VAR_REAL(unit, nvarid, zdata)
+#endif
+
+c-----------------------------------------------------------------------
+c        Cas particulier "Francois Lott" ( k=4 ) (relief sous-maille)
+c-----------------------------------------------------------------------
+      if (k.eq.4) then
+
+          call multscal(imd*jmdp1,zdata,1000.,zdata)
+          call multscal(imd,longitude,pi/180.,longitude)
+          call multscal(jmdp1,latitude,pi/180.,latitude)
+
+          call grid_noro1(360, 180, longitude, latitude, zdata,
+     .         iim, jjp1, rlonv, rlatu, zmea,zstd,zsig,zgam,zthe)
+
+          CALL dump2d(iip1,jjp1,zmea,'zmea')
+          CALL dump2d(iip1,jjp1,zstd,'zstd')
+          CALL dump2d(iip1,jjp1,zsig,'zsig')
+          CALL dump2d(iip1,jjp1,zgam,'zgam')
+          CALL dump2d(iip1,jjp1,zthe,'zthe')
+
+      endif
+
+c-----------------------------------------------------------------------
+c   Passage de zdata en grille (imdp1 jmdp1)
+c-----------------------------------------------------------------------
+      do j=1,jmdp1
+          do i=1,imd
+              zdataS(i+imdp1*(j-1)) = zdata(i+ngridmxgdat*(j-1))
+          enddo
+          zdataS(imdp1+imdp1*(j-1)) = zdata(1+ngridmxgdat*(j-1))
+      enddo
+
+c-----------------------------------------------------------------------
+c    Interpolation
+c-----------------------------------------------------------------------
+      call interp_horiz(zdataS,pfield,imd,jmd,
+     .    iim, jjm,1,rlonud,rlatvd,rlonu,rlatv) 
+
+c-----------------------------------------------------------------------
+c    Periodicite    
+c-----------------------------------------------------------------------
+
+      do j=1,jjp1
+         pfield(iimp1*j) =  pfield(1+iimp1*(j-1))
+      enddo 
+ 
+c-----------------------------------------------------------------------
+c    Sauvegarde des champs    
+c-----------------------------------------------------------------------
+
+      if (k.eq.1) then                    ! albedo
+         do i=1,iimp1*jjp1
+              alb(i) = pfield(i)
+          enddo
+      elseif (k.eq.2) then                ! thermal
+         do i=1,iimp1*jjp1
+              ith(i) = pfield(i)
+          enddo
+      elseif (k.eq.3) then                ! relief
+        if (relief.eq.'pla') then
+              call initial0(iimp1*jjp1,phisinit)
+        else
+             do i=1,iimp1*jjp1
+                  phisinit(i) = pfield(i)
+              enddo
+        endif
+      endif
+
+      ENDDO
+
+c-----------------------------------------------------------------------
+c    Traitement Phisinit
+c-----------------------------------------------------------------------
+
+      DO i=1,iimp1*jjp1
+            phisinit(i)=1000.*phisinit(i)
+      ENDDO
+      CALL dump2d(iimp1,jjp1,phisinit,'Altitude en m')
+      CALL multscal(iimp1*jjp1,phisinit,g,phisinit)
+
+c-----------------------------------------------------------------------
+c    FIN
+c-----------------------------------------------------------------------
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dedd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dedd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dedd.F	(revision 57)
@@ -0,0 +1,156 @@
+      SUBROUTINE DEDD (KDLON,PGG,PREF,PRMUZ,PTO1,PW
+     S                ,      PRE1,PRE2,PTR1,PTR2         )
+      implicit none
+C
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+C
+C**** *DEDD* - DELTA-EDDINGTON IN A CLOUDY LAYER
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C**   INTERFACE.
+C     ----------
+C          *DEDD* IS CALLED BY *SW*.
+C
+C     SUBROUTINE DEDD (KDLON,PGG,PREF,PRMUZ,PTO1,PW
+C    S                ,      PRE1,PRE2,PTR1,PTR2         )
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C PGG    : (NDLON)             ; ASSYMETRY FACTOR
+C PREF   : (NDLON)             ; REFLECTIVITY OF THE UNDERLYING LAYER
+C PRMUZ  : (NDLON)             ; COSINE OF SOLAR ZENITH ANGLE
+C PTO1   : (NDLON)             ; OPTICAL THICKNESS
+C PW     : (NDLON)             ; SINGLE SCATTERING ALBEDO
+C     ==== OUTPUTS ===
+C PRE1   : (NDLON)             ; LAYER REFLECTIVITY ASSUMING NO
+C                              ; REFLECTION FROM UNDERLYING LAYER
+C PTR1   : (NDLON)             ; LAYER TRANSMISSIVITY ASSUMING NO
+C                              ; REFLECTION FROM UNDERLYING LAYER
+C PRE2   : (NDLON)             ; LAYER REFLECTIVITY ASSUMING
+C                              ; REFLECTION FROM UNDERLYING LAYER
+C PTR2   : (NDLON)             ; LAYER TRANSMISSIVITY ASSUMING
+C                              ; REFLECTION FROM UNDERLYING LAYER
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     EXTERNALS.
+C     ----------
+C
+C          NONE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "IN CORE MODEL"
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+      INTEGER KDLON
+C
+      REAL PGG(NDLO2),PREF(NDLO2),PRMUZ(NDLO2),PTO1(NDLO2),PW(NDLO2)
+      REAL PRE1(NDLO2),PRE2(NDLO2),PTR1(NDLO2),PTR2(NDLO2)
+
+c   local
+      integer jl
+      real*8 ZFF,ZGP,ZTOP,ZWCP,ZDT,ZX1,ZWM,ZRM2,ZRK,ZX2,ZRP,ZALPHA
+      real*8 ZBETA,ZEXMU0,ZEXKP,ZEXKM,ZXP2P,ZXM2P,ZAP2B,ZAM2B
+      real*8 ZA11,ZA12,ZA13,ZA22,ZA21,ZA23,ZDENA,ZC1A,ZC2A
+      real*8 ZRI0A,ZRI1A,ZRI0B,ZRI1B
+      real*8 ZB21,ZB22,ZB23,ZDENB,ZC1B,ZC2B
+      real*8 ZRI0C,ZRI1C,ZRI0D,ZRI1D
+C
+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 = SQRT(3.*ZWM/ZX1)
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+      ZEXMU0 = EXP(-ZTOP/ PRMUZ(JL) )
+      ZEXKP = EXP(ZRK*ZTOP)
+      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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/def_var.F90
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/def_var.F90	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/def_var.F90	(revision 57)
@@ -0,0 +1,61 @@
+subroutine def_var(nid,name,title,units,nbdim,dimids,nvarid,ierr)
+
+! This subroutine defines variable 'name' in a (pre-existing and opened)
+! NetCDF file (known from its NetCDF ID 'nid').
+! The number of dimensions 'nbdim' of the variable, as well as the IDs of
+! corresponding dimensions must be set (in array 'dimids').
+! Upon successfull definition of the variable, 'nvarid' contains the
+! NetCDF ID of the variable.
+! The variables' attributes 'title' (Note that 'long_name' would be more
+! appropriate) and 'units' are also set. 
+
+implicit none
+
+#include "netcdf.inc"
+
+integer,intent(in) :: nid ! NetCDF file ID
+character(len=*),intent(in) :: name ! the variable's name
+character(len=*),intent(in) :: title ! 'title' attribute of variable
+character(len=*),intent(in) :: units ! 'units' attribute of variable
+integer,intent(in) :: nbdim ! number of dimensions of the variable
+integer,dimension(nbdim),intent(in) :: dimids ! NetCDF IDs of the dimensions
+                                              ! the variable is defined along
+integer,intent(out) :: nvarid ! NetCDF ID of the variable
+integer,intent(out) :: ierr ! returned NetCDF staus code
+
+! 1. Switch to NetCDF define mode 
+ierr=NF_REDEF(nid)
+
+! 2. Define the variable
+#ifdef NC_DOUBLE
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dimids,nvarid)
+#else
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dimids,nvarid)
+#endif
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed defining variable "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 3. Write attributes
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"title",&
+                     len_trim(adjustl(title)),adjustl(title))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed writing title attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"units",&
+                     len_trim(adjustl(units)),adjustl(units))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var: Failed writing units attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 4. Switch out of NetCDF define mode
+ierr = NF_ENDDEF(nid)
+
+end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimphys.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimphys.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimphys.h	(revision 57)
@@ -0,0 +1,8 @@
+!-----------------------------------------------------------------------
+!   INCLUDE 'dimphys.h'
+
+      INTEGER, PARAMETER :: ngridmx = (2+(jjm-1)*iim - 1/jjm)   
+      integer, parameter :: nlayermx = llm 
+      integer, parameter :: nsoilmx = 10
+
+!-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimradmars.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimradmars.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dimradmars.h	(revision 57)
@@ -0,0 +1,76 @@
+c-----------------------------------------------------------------------
+c------------------------------------------------------------------------
+c   INCLUDE 'dimradmars.h'
+
+c   Declaration and initialisation or radiative transfer calculations
+c------------------------------------------------------------------------
+c------------------------------------------------------------------------
+
+c Splitting of horizontal grid (to reduce program size on workstation)
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c nflev: number of vertical layer
+c ndlon: nombre de points de la grille horizontale
+c NDLO2 et ndomainsz pour le decoupage de l'appel a la physique
+c ATTENTION:  Il faut  1 < ndomainsz =< ngridmx
+
+      INTEGER  NFLEV,NDLON, ndomainsz, NDLO2
+
+       parameter (ndomainsz=ngridmx)
+c     parameter (ndomainsz=(ngridmx-1)/20 + 1)
+c      parameter (ndomainsz=(ngridmx-1)/5 + 1)
+
+      parameter (NFLEV=nlayermx,NDLON=ndomainsz)	! avec decoupage 
+      parameter (NDLO2=NDLON)
+
+
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      REAL longrefir,longrefvis
+      REAL long1vis,long2vis,long3vis, long1ir,long2ir
+      REAL long1co2,long2co2
+      REAL sunfr(2)
+      integer nir, nuco2
+      INTEGER npademx,nabsmx,nt_pademx, NSUN
+
+
+c Definition of spectral intervals at thermal infrared wavelengths (LW)
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      parameter (nir=4) ! Total number of thermal IR bands
+      parameter (nuco2=2) ! number of bands in CO2 bands
+      PARAMETER (long1ir=5.E-6 , long2ir=200.E-6)
+      PARAMETER (long1co2=1.E+0 / 865.E+2 , long2co2=1.E+0 / 500.E+2)
+
+c  Warning : the "nir" thermal IR bands are not ordered by wavelength:
+c      iir=1 : central 15um CO2 bands \    
+c      iir=2 : CO2 band wings    [long1co2-long2co2] MINUS central band
+c      iir=3 : 9 um band [long1ir - long1co2]
+c      iir=4 : Far IR    [long2co2 - long2ir]
+    
+c  Definition of spectral interval at solar wavelengths (SW)
+c  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      PARAMETER (NSUN=2)   ! do not change that !
+c  Boundaries of spectral intervals (m) : 
+      PARAMETER (long1vis=0.1E-6 , long2vis=0.5E-6 , long3vis=5.E-6)
+c  Fraction of solar energy in solar band #1 [long1vis-long2vis]
+      DATA sunfr(1) / 0.274490 /  
+c  Fraction of solar energy in solar band #2 [long2vis-long3vis]
+      DATA sunfr(2) / 0.725509 /
+
+c Reference wavelengths used to compute reference dust optical depth (m)
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      PARAMETER (longrefir=9.E-6,longrefvis=0.67E-6)
+
+c Number of kind of tracer radiative properties 
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c (ex: naerkind=1 if you use one dust mode without ice ...)
+c (ex: naerkind=2 if you use one dust mode and active ice ...)
+      integer naerkind        
+      parameter (naerkind=1)
+
+c Various initialisation for LW radiative code
+c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c npademx : nombre de coef de pade 
+c nabsmx : ?
+c nt_pademx : nombre d'intervalles de temperature pour pade
+
+      PARAMETER (npademx=4,nabsmx=2,nt_pademx=19)
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/drag_noro.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/drag_noro.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/drag_noro.F	(revision 57)
@@ -0,0 +1,166 @@
+      SUBROUTINE drag_noro (klon,klev,dtime,pplay,pplev,
+     e                   pvar, psig, pgam, pthe,
+     e                   kgwd,kgwdim,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+C**** *DRAG_NORO* INTERFACE FOR SUB-GRID SCALE OROGRAPHIC SCHEME
+C
+C     PURPOSE.
+C     --------
+C           ZEROS TENDENCIES, COMPUTES GEOPOTENTIAL HEIGHT AND UPDATES THE
+C           TENDENCIES AFTER THE SCHEME HAS BEEN CALLED.
+C
+C     EXPLICIT ARGUMENTS :
+C     --------------------
+C
+C     INPUT :
+C
+C     NLON               : NUMBER OF HORIZONTAL GRID POINTS
+C     NLEV               : NUMBER OF LEVELS
+C     DTIME              : LENGTH OF TIME STEP
+C     PPLAY(NLON,NLEV+1) : PRESSURE AT MIDDLE LEVELS
+C     PPLEV(NLON,NLEV)   : PRESSURE ON MODEL LEVELS
+C     PVAR(NLON)         : SUB-GRID SCALE STANDARD DEVIATION
+C     PSIG(NLON)         : SUB-GRID SCALE SLOPE
+C     PGAM(NLON)         : SUB-GRID SCALE ANISOTROPY
+C     PTHE(NLON)         : SUB-GRID SCALE PRINCIPAL AXES ANGLE
+C     KGWD               : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
+C     KGWDIM             : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
+C     KDX(NLON)          : POINTS AT WHICH TO CALL THE SCHEME
+C     KTEST(NLON)        : MAP OF CALLING POINTS
+C     T(NLON,NLEV)       : TEMPERATURE
+C     U(NLON,NLEV)       : ZONAL WIND
+C     V(NLON,NLEV)       : MERIDIONAL WIND
+C
+C     OUTPUT :
+C
+C     PULOW(NLON)        : LOW LEVEL ZONAL WIND
+C     PVLOW(NLON)        : LOW LEVEL MERIDIONAL WIND
+C     PUSTR(NLON)        : LOW LEVEL ZONAL STRESS
+C     PVSTR(NLON)        : LOW LEVEL MERIDIONAL STRESS
+C     D_T(NLON,NLEV)     : TEMPERATURE TENDENCY
+C     D_U(NLON,NLEV)     : ZONAL WIND TENDENCY
+C     D_V(NLON,NLEV)     : MERIDIONAL WIND TENDENCY
+C
+C     IMPLICIT ARGUMENTS :
+C     --------------------
+C
+C     comcstfi.h
+C     dimphys.h
+C
+c
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li 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 s-------input-R-la valeur "s" pour chaque couche
+c pplay--input-R- pression au milieu des couches en Pa
+c pplev--input-R-pression au bords des couches 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 t
+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 "dimphys.h"
+#include "dimradmars.h"
+#include "comcstfi.h"
+c
+c ARGUMENTS
+c
+      REAL dtime
+      INTEGER klon,klev
+      real pplay(NDLO2,klev),pplev(NDLO2,klev+1)
+      REAL pvar(NDLO2),psig(NDLO2),pgam(NDLO2),pthe(NDLO2)
+      REAL pulow(NDLO2),pvlow(NDLO2),pustr(NDLO2),pvstr(NDLO2)
+      REAL u(NDLO2,klev), v(NDLO2,klev),t(NDLO2,klev)
+      REAL d_t(NDLO2,klev), d_u(NDLO2,klev), d_v(NDLO2,klev)
+c
+      INTEGER i, k, kgwd, kgwdim, kdx(NDLO2), ktest(NDLO2)
+c
+c Variables locales:
+c
+      REAL paprs(NDLO2,nlayermx+1)
+      REAL paprsf(NDLO2,nlayermx)
+      REAL zgeom(NDLO2,nlayermx)
+      REAL pdtdt(NDLO2,nlayermx)
+      REAL pdudt(NDLO2,nlayermx), pdvdt(NDLO2,nlayermx)
+      REAL pt(NDLO2,nlayermx), pu(NDLO2,nlayermx)
+      REAL pv(NDLO2,nlayermx)
+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)
+         paprsf(i,k) = pplay(i,klev-k+1)
+         paprs(i,k) = pplev(i,klev+1-k+1)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pplev(i,1)
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = r * pt(i,klev)
+     .                  * LOG(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) + r * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(paprsf(i,k+1)/paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+
+      CALL ORODRAG(klon,klev,kgwd,kgwdim,kdx,ktest,
+     .            dtime,
+     .            paprs, paprsf, zgeom,
+     .            pt, pu, pv, pvar, psig, pgam, pthe,
+     .            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)
+     .                    +g*pdudt(i,k)*(paprs(i,k+1)-paprs(i,k))
+         pvstr(i)        = pvstr(i)
+     .                    +g*pdvdt(i,k)*(paprs(i,k+1)-paprs(i,k))
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustdevil.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustdevil.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustdevil.F	(revision 57)
@@ -0,0 +1,250 @@
+      SUBROUTINE dustdevil(ngrid,nlay,nq, pplev,pu,pv,pt, ptsurf,pq2,
+     &                pdqdev,pdqs_dev)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c
+c  VERSION SPECIAL TRACEURS :
+c  Parameterization of dust devil activities
+c  to estimate dust lifting
+c  The dust devil activity is estimated based on 
+c  Renno et al. 1998 (JAS 55, 3244-3252)  
+c
+c  It is proportional to (1-b)*Fs
+c
+c  With b= [ps**(rcp+1) - ptop**(rcp+1)] / [(ps-ptop)*(rcp+1)* ps**rcp]
+c  with ptop pressure of the top of the boundary layer
+c       rcp = R/cp
+c
+c  and Fs the surface sensible heat flux = Cd*|U|*(T(1) -Tsurf)
+c       
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"      
+c#include "comconst.h"        ! TEMPORAIRE AVEC ANLDEVIL !!!!
+#include "planete.h"
+#include "comgeomfi.h"
+#include "tracer.h"
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL pplev(ngrid,nlay+1)
+      REAL pt(ngrid,nlay)
+      REAL pu(ngrid,nlay)
+      REAL pv(ngrid,nlay)
+      REAL pq2(ngrid,nlay+1)
+      REAL ptsurf(ngrid)
+
+c    Traceurs :
+      integer nq 
+      real pdqdev(ngrid,nlay,nq) 
+      real pdqs_dev(ngrid,nq) 
+      
+c   local:
+c   ------
+
+      INTEGER ig,l,iq
+      real Cd, z1
+      save Cd
+
+      LOGICAL firstcall
+      SAVE firstcall
+
+
+      REAL devila(ngridmx)
+      integer ltop(ngridmx)
+      real b,rho,Fs,wind
+
+
+
+      REAL  q2top , seuil
+      SAVE  q2top , seuil
+      DATA q2top/.5/ ! value of q2 at the top of PBL
+      DATA seuil/.3/ ! value of minimum dust devil activity for dust lifting
+
+
+      DATA firstcall/.true./
+
+c   TEMPORAIRE AVEC ANLDEVIL : *************
+c        real b_diag(ngridmx)
+c       real localtime(ngridmx)
+c       common/temporaire/localtime
+c      real ztop(ngridmx),magwind(ngridmx),t1(ngridmx)
+c      real rcp ,cpp
+c      rcp = kappa
+c      cpp = r/rcp
+c   **********************************
+       
+
+c-----------------------------------------------------------------------
+c    initialisation
+c    --------------
+
+      IF (firstcall) THEN
+
+        write(*,*) 'In dustdevil :'
+        write(*,*) '    q2top= ',q2top,'     seuil= ', seuil 
+c       un petit test de coherence:
+         IF(ngrid.NE.ngridmx) THEN
+            PRINT*,'STOP dans coefdifv'
+            PRINT*,'probleme de dimensions :'
+            PRINT*,'ngrid  =',ngrid
+            PRINT*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+
+c A rough estimation of the horizontal drag coefficient Cd
+c (the scale heigh is taken to be 13 km since we are typically
+c dealing with daytime temperature around 250K.
+c 
+         z1= -0.5*13.e3*log(pplev(1,2)/pplev(1,1))
+         Cd = (0.4/log(z1/z0))**2
+
+         firstcall=.false.
+
+c        Temporaire
+c        open(77,file='devil')
+      
+      ENDIF
+
+c-----------------------------------------------------------------------
+c Initialisation
+      do iq=1,nq
+       do l=1,nlay
+           do ig=1,ngrid
+             pdqdev(ig,l,iq)= 0
+           end do
+       end do
+      end do
+
+
+c-----------------------------------------------------------------------
+c      Determining the top of the boundary layer
+c      ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      do ig=1,ngrid
+         do  l=2,nlay-1
+            if (pq2(ig,l).lt.q2top)then
+              ltop(ig)=l
+              goto 99
+            end if
+         enddo
+ 99      continue
+
+c        ***************************************
+cc        if (ptsurf(ig).gt.255)then
+c         write(*,*) 'tsurf, ztop (km): ', ig,
+c     &   ptsurf(ig), -12.*log(pplev(ig,ltop(ig))/pplev(ig,1))
+c         if ((ptsurf(ig).gt.50.).and.(
+c     &      (-12.*log(pplev(ig,ltop(ig))/pplev(ig,1))).gt.60.))then
+c            do l=1,nlay
+c             write(*,*) l,
+c     &       -12.*log(pplev(ig,l)/pplev(ig,1)),pq2(ig,l)
+c            end do
+c         end if
+cc        end if
+c        ***************************************
+     
+      enddo
+
+c        ***************************************
+c        do ig=100,148
+c           write(*,*)'time,tsurf,ztop', localtime(ig),ptsurf(ig),
+c    &      -12.*log(pplev(ig,ltop(ig))/pplev(ig,1))
+c        end do
+c        ***************************************
+
+
+c   Calculation : dust devil intensity
+c   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      do ig=1,ngrid
+
+c --------------------------------------------------
+c 1) Version 1 : sensible heat flux using actual wind :
+c        Wind magnitude:
+c        wind = sqrt(pu(ig,1)**2+pv(ig,1)**2)
+c
+c --------------------------------------------------
+c 2) Version 2 : sensible heat flux using  wind = 15 m/s
+         wind = 15.
+c ----------------------------------------------------
+c        Density :
+         rho=pplev(ig,1)/(R*pt(ig,1))
+
+c        Sensible heat flux (W.m-2) (>0 if up)
+         Fs= rho*cpp*Cd * wind
+     &       * (ptsurf(ig) -pt(ig,1))
+         b= (pplev(ig,1)**(rcp+1) - pplev(ig,ltop(ig))**(rcp+1)) /
+     &    ( (pplev(ig,1)-pplev(ig,ltop(ig)))*(rcp+1)*pplev(ig,1)**rcp)
+
+c        b_diag(ig) = b     ! TEMPORAIRE (pour diagnostique)
+
+c   Energy flux available to drive dust devil (W.m-2) : (1-b)*Fs
+c   Dust devil activity : 
+         devila(ig)= max( 0. , (1-b)*Fs - seuil ) 
+      enddo
+c   
+c     lifted dust (kg m-2 s-1)  (<0 when lifting)
+c     ~~~~~~~~~~  
+      do iq=1,nq
+         do ig=1,ngrid
+           pdqs_dev(ig,iq)= - alpha_devil(iq) * devila(ig)
+         end do
+      end do 
+
+c     Injection of dust in the atmosphere (up to the top of pbl)
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      do iq=1,nq
+       do ig=1,ngrid
+         if (devila(ig).ne.0.) then
+           do l=1,ltop(ig)
+             pdqdev(ig,l,iq)=-pdqs_dev(ig,iq)*g/
+     &        (pplev(ig,1)-pplev(ig,ltop(ig)))
+           end do
+         end if
+       end do
+      end do
+
+c *********************************************************     
+c     TEMPORAIRE AVEC ANLDEVIL:
+c     IF (ngrid.gt.1) THEN
+c      do ig=2,ngridmx-1
+c       write(77,88) lati(ig)*180./pi,localtime(ig),
+c    &        -12.*log(pplev(ig,ltop(ig))/pplev(ig,1)),
+c    &   devil(ig),min(sqrt(pu(ig,1)**2+pv(ig,1)**2),40.),
+c    &   ptsurf(ig)-pt(ig,1),ptsurf(ig),pplev(ig,1)
+c      end do    
+c88    format (f7.3,1x,f7.3,1x,f6.3,1x,f6.4,1x,f7.4,1x,
+c    &        f7.3,1x,f7.3,1x,f9.3)
+c      do ig=1,ngridmx
+c       ztop(ig) = -12.*log(pplev(ig,ltop(ig))/pplev(ig,1))
+c       magwind(ig) = sqrt(pu(ig,1)**2+pv(ig,1)**2)
+c       t1(ig) =max(ptsurf(ig)- pt(ig,1),0.)
+c      end do
+
+c       call WRITEDIAGFI(ngridmx,'dqs_dev','dqs devil',
+c    &               'kg.m-2.s-1',2,pdqs_dev)
+c       call WRITEDIAGFI(ngridmx,'wind','wind',
+c    &               'm.s-1',2,magwind)
+c       call WRITEDIAGFI(ngridmx,'ztop','top pbl',
+c    &               'km',2,ztop)
+c       call WRITEDIAGFI(ngridmx,'tsurf','tsurf',
+c    &               'K',2,ptsurf)
+c       call WRITEDIAGFI(ngridmx,'T1','T(1)',
+c    &               'K',2,t1)
+c       call WRITEDIAGFI(ngridmx,'b','b',
+c    &               ' ',2,b_diag)
+c     END If
+c *********************************************************     
+         
+      RETURN
+      END
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustlift.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustlift.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustlift.F	(revision 57)
@@ -0,0 +1,110 @@
+      SUBROUTINE dustlift(ngrid,nlay,nq,rho,pcdh_true,pcdh,co2ice,
+     $                  dqslift)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Dust lifting by surface winds
+c  Computing flux to the middle of the first layer
+c  (Called by vdifc)
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "tracer.h"
+
+c
+c   arguments:
+c   ----------
+
+c   INPUT
+      integer ngrid, nlay, nq  
+      real rho(ngrid)  ! density (kg.m-3) at surface
+      real pcdh_true(ngrid) ! Cd 
+      real pcdh(ngrid) ! Cd * |V| 
+      real co2ice(ngrid)
+
+c   OUTPUT
+      real dqslift(ngrid,nq) !surface dust flux to mid-layer (<0 when lifing)
+c     real pb(ngrid,nlay) ! diffusion to surface coeff.
+
+c   local:
+c   ------
+      INTEGER ig,iq
+      REAL fhoriz(ngridmx)  ! Horizontal dust flux 
+      REAL ust,us
+      REAL stress_seuil
+      SAVE stress_seuil
+      DATA stress_seuil/0.0225/   ! stress seuil soulevement (N.m2)
+
+
+c     ---------------------------------
+c     Computing horizontal flux: fhoriz
+c     ---------------------------------
+
+      do ig=1,ngrid
+          fhoriz(ig) = 0.      ! initialisation
+
+c         Selection of points where surface dust is available
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c         if (latid(ig).ge.80.) goto 99  ! N permanent  polar caps
+c         if (latid(ig).le.-80.) goto 99 ! S polar deposits
+c         if  ((longd(ig).ge.-141. .and. longd(ig).le.-127.)
+c    &   .and.(latid(ig).ge.12.   .and. latid(ig).le.23.))goto 99 ! olympus
+c         if  ((longd(ig).ge.-125. .and. longd(ig).le.-118.)
+c    &   .and.(latid(ig).ge.-12.   .and. latid(ig).le.-6.))goto 99 ! Arsia
+c         if  ((longd(ig).ge.-116. .and. longd(ig).le.-109.)
+c    &   .and.(latid(ig).ge.-5.   .and. latid(ig).le. 5.))goto 99 ! pavonis
+c         if  ((longd(ig).ge.-109. .and. longd(ig).le.-100.)
+c    &   .and.(latid(ig).ge. 7.   .and. latid(ig).le. 16.))goto 99 ! ascraeus
+c         if  ((longd(ig).ge.  61. .and. longd(ig).le.  63.)
+c    &   .and.(latid(ig).ge. 63. .and. latid(ig).le. 64.))goto 99 !weird point
+          if (co2ice(ig).gt.0.) goto 99
+
+
+c         Is the wind strong enough ?
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          ust = sqrt(stress_seuil/rho(ig))
+          us = pcdh(ig) /  sqrt(pcdh_true(ig)) ! ustar=cd*v /sqrt(cd)
+          if (us.gt.ust) then
+c            If lifting ? 
+c            Calcul du flux suivant Marticorena ( en fait white (1979))
+
+             fhoriz(ig) = 2.61*(rho(ig)/g) *
+     &      (us -ust) * (us + ust)**2
+          end if
+ 99      continue
+      end do
+
+c     -------------------------------------
+c     Computing vertical flux and diffusion
+c     -------------------------------------
+ 
+       do iq=1,nq
+         do ig=1,ngrid
+             dqslift(ig,iq)= -alpha_lift(iq)* fhoriz(ig)
+
+
+cc  le  flux vertical remplace le terme de diffusion turb. qui est mis a zero
+c            zb(ig,1) = 0.
+cc           If surface deposition by turbulence diffusion (impaction...)
+cc           if(fhoriz(ig).ne.0) then
+cc           zb(ig,1) = zcdh(ig)*zb0(ig,1)
+cc           AMount of Surface deposition !
+cc           pdqs_dif(ig,iq)=pdqs_dif(ig,iq) +
+cc    &      zb(ig,1)*zq(ig,1,iq)/ptimestep
+cc          write(*,*) 'zb(1)  = ' ,  zb(ig,1),zcdh(ig),zb0(ig,1)
+cc
+
+         enddo
+       enddo
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustopacity.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustopacity.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/dustopacity.F	(revision 57)
@@ -0,0 +1,286 @@
+      SUBROUTINE dustopacity(ngrid,nlayer,nq,zday,pplay,pplev,ls,pq,
+     $    tauref,tau,aerosol)
+                                                   
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing aerosol optical depth (dust opacity) 
+c   In each layers
+c
+c   author: F.Forget 
+c   ------
+c   update F. Montmessin (water ice scheme) 
+c      and S. Lebonnois (12/06/2003) compatibility dust/ice/chemistry
+c   
+c   input:
+c   ----- 
+c   ngrid             Number of gridpoint of horizontal grid
+c   nlayer            Number of layer
+c   nq                Number of tracer
+c   ls                Solar longitude (Ls) , radian
+c   pplay,pplev       pressure (Pa) in the middle and boundary of each layer
+c   pq                Dust mixing ratio (used if tracer =T and active=T).
+c
+c   output:
+c   -------
+c   tauref       Prescribed mean column optical depth at 700 Pa 
+c   tau          Column total visible dust optical depth at each point
+c   aerosol      aerosol(ig,l,1) is the dust optical
+c                depth in layer l, grid point ig
+
+c
+c=======================================================================
+#include "dimensions.h"
+#include "dimphys.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "comgeomfi.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+#include "tracer.h"
+#include "planete.h"
+
+c-----------------------------------------------------------------------
+c
+c    Declarations :
+c    --------------
+c
+c    Input/Output
+c    ------------
+      INTEGER ngrid,nlayer,nq
+
+      REAL ls,zday,expfactor    
+      REAL pplev(ngrid,nlayer+1),pplay(ngrid,nlayer)
+      REAL pq(ngrid,nlayer,nq)
+      REAL tauref(ngrid), tau(ngrid,naerkind)
+      REAL aerosol(ngrid,nlayer,naerkind)
+c
+c    Local variables :
+c    -----------------
+      INTEGER l,ig,iq
+      real topdust(ngridmx)
+      real zlsconst, zp
+      real taueq,tauS,tauN
+      real r0,reff,coefsize
+c
+c   local saved variables
+c   ---------------------
+
+      REAL topdust0(ngridmx) 
+      SAVE topdust0
+
+      LOGICAL firstcall
+      DATA firstcall/.true./
+      SAVE firstcall
+
+
+c----------------------------------------------------------------------
+
+c     Initialisation
+c     --------------
+
+      IF (firstcall) THEN
+
+c        altitude of the top of the aerosol layer (km) at Ls=2.76rad:
+c        in the Viking year scenario
+         DO ig=1,ngrid
+             topdust0(ig)=60. -22.*SIN(lati(ig))**2
+         END DO
+         firstcall=.false.
+      END IF
+
+c  -------------------------------------------------------------
+c     1) Prescribed dust  (if tracer=F or active=F)
+c  -------------------------------------------------------------
+      IF ((.not.tracer) .or. (.not.active)) THEN 
+
+c       Vertical column optical depth at 700.Pa 
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        IF(iaervar.eq.1) THEN
+           do ig=1, ngridmx
+            tauref(ig)=max(tauvis,1.e-9) ! tauvis=cste as read in starfi
+          end do
+        ELSE IF (iaervar.eq.2) THEN   ! << "Viking" Scenario>>
+
+          tauref(1) = 0.7+.3*cos(ls+80.*pi/180.) ! like seen by VL1
+          do ig=2,ngrid
+            tauref(ig) = tauref(1)
+          end do
+
+        ELSE IF (iaervar.eq.3) THEN  ! << "MGS" scenario >>
+
+           taueq= 0.2 +(0.5-0.2) *(cos(0.5*(ls-4.363)))**14
+           tauS= 0.1 +(0.5-0.1)  *(cos(0.5*(ls-4.363)))**14
+           tauN = 0.1
+c	   if (peri_day.eq.150) then
+c	     tauS=0.1
+c	     tauN=0.1 +(0.5-0.1)  *(cos(0.5*(ls+pi-4.363)))**14
+c	     taueq= 0.2 +(0.5-0.2) *(cos(0.5*(ls+pi-4.363)))**14
+c           endif
+	     
+           do ig=1,ngrid/2  ! Northern hemisphere
+             tauref(ig)= tauN +
+     &       (taueq-tauN)*0.5*(1+tanh((45-lati(ig)*180./pi)*6/60))
+           end do
+           do ig=ngrid/2+1, ngridmx  ! Southern hemisphere
+             tauref(ig)= tauS +
+     &       (taueq-tauS)*0.5*(1+tanh((45+lati(ig)*180./pi)*6/60))
+           end do
+
+        ELSE IF (iaervar.eq.4) THEN  ! << "TES scenario >>
+           call readtesassim(ngrid,nlayer,zday,pplev,tauref)
+
+        ELSE IF (iaervar.eq.5) THEN   ! << Escalier Scenario>>
+c         tauref(1) = 0.2
+c         if ((ls.ge.210.*pi/180.).and.(ls.le.330.*pi/180.))
+c    &                              tauref(1) = 2.5
+          tauref(1) = 2.5
+          if ((ls.ge.30.*pi/180.).and.(ls.le.150.*pi/180.))
+     &                              tauref(1) = .2
+
+          do ig=2,ngrid
+            tauref(ig) = tauref(1)
+          end do
+        ELSE
+          stop 'problem with iaervar in dustopacity.F'
+        ENDIF
+
+c       Altitude of the top of the dust layer
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        zlsconst=SIN(ls-2.76)
+        if (iddist.eq.1) then
+          do ig=1,ngrid
+             topdust(ig)=topdustref         ! constant dust layer top
+          end do
+
+        else if (iddist.eq.2) then          ! "Viking" scenario
+          do ig=1,ngrid
+            topdust(ig)=topdust0(ig)+18.*zlsconst
+          end do
+
+        else if(iddist.eq.3) then         !"MGS" scenario
+          do ig=1,ngrid
+            topdust(ig)=60.+18.*zlsconst
+     &                -(32+18*zlsconst)*sin(lati(ig))**4
+     &                 - 8*zlsconst*(sin(lati(ig)))**5
+          end do
+        endif
+
+
+c       Optical depth in each layer :
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        if(iddist.ge.1) then
+         expfactor=0.
+          DO l=1,nlayer
+             DO ig=1,ngrid
+             if(pplay(ig,l).gt.700.
+     $                        /(988.**(topdust(ig)/70.))) then
+                zp=(700./pplay(ig,l))**(70./topdust(ig))
+                 expfactor=max(exp(0.007*(1.-max(zp,1.))),1.e-3)
+              else    
+               expfactor=1.e-3
+              endif       
+                aerosol(ig,l,1)= tauref(ig)/700. *
+     s           (pplev(ig,l)-pplev(ig,l+1))
+     &           *expfactor
+c     s           *max( exp(.007*(1.-max(zp,1.))) , 1.E-3 )
+             ENDDO
+          ENDDO
+c     changement dans le calcul de la distribution verticale          
+c     dans le cas des scenarios de poussieres assimiles
+c        if (iaervar.eq.4) THEN  ! TES
+c        call zerophys(ngrid*naerkind,tau)
+c
+c        do l=1,nlayer
+c           do ig=1,ngrid
+c                tau(ig,1)=tau(ig,1)+ aerosol(ig,l,1)
+c           end do
+c        end do
+c        do l=1,nlayer
+c           do ig=1,ngrid
+c               aerosol(ig,l,1)=aerosol(ig,l,1)*tauref(ig)/tau(ig,1)
+c     $     *(pplev(ig,1)/700)
+c           end do
+c        end do
+c        endif
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc       
+        else if(iddist.eq.0) then   
+c         old dust vertical distribution function (pollack90)
+          DO l=1,nlayer
+             DO ig=1,ngrid
+                zp=700./pplay(ig,l)
+                aerosol(ig,l,1)= tauref(ig)/700. *
+     s           (pplev(ig,l)-pplev(ig,l+1))
+     s           *max( exp(.03*(1.-max(zp,1.))) , 1.E-3 )
+             ENDDO
+          ENDDO
+        end if
+
+c  ---------------------------------------------------------------------
+c     2) Transported radiatively active dust  (if tracer=T and active=T)
+c ----------------------------------------------------------------------
+      ELSE  IF ((tracer) .and. (active)) THEN 
+c     The dust opacity is computed from q
+
+c     a) "doubleq" technique (transport of mass and number mixing ratio)
+c        ~~~~~~~~~~~~~~~~~~~
+       if(doubleq) then 
+
+         call zerophys(ngrid*nlayer*naerkind,aerosol)
+
+c        Computing effective radius :
+         do  l=1,nlayer
+           do ig=1, ngrid
+              r0=
+     &        (r3n_q*pq(ig,l,1)/max(pq(ig,l,2),0.01))**(1./3.)
+              r0=min(max(r0,1.e-10),500.e-6)
+              reff= ref_r0 * r0
+cc           If  reff is small, the transported dust mean Qext
+c            is reduced from the reference dust Qext by a factor "coefsize"
+
+             coefsize=min(max(2.52e6*reff-0.043 ,0.)   ,1.)
+
+cc              It is added 1.e-8 to pq to avoid low
+
+                aerosol(ig,l,1)=aerosol(ig,l,1)+ 1.E-8 +
+     &         ( 0.75*Qext(1)*coefsize/(rho_dust*reff))
+     &          * (pq(ig,l,1))*
+     &          (pplev(ig,l)-pplev(ig,l+1))/g
+           end do
+         end do
+         call zerophys(ngrid,tauref)
+
+c     b) Size bin technique (each aerosol can contribute to opacity))
+c        ~~~~~~~~~~~~~~~~~~
+       else
+c        The dust opacity is computed from q
+         call zerophys(ngrid*nlayer*naerkind,aerosol)
+         do iq=1,dustbin
+           do l=1,nlayer
+              do ig=1,ngrid
+cc               qextrhor(iq) is  (3/4)*Qext/(rho*reff)
+cc               It is added 1.e-8 to pq to avoid low
+                 aerosol(ig,l,1)=aerosol(ig,l,1)+
+     &           qextrhor(iq)* (pq(ig,l,iq) + 1.e-8)*
+     &           (pplev(ig,l)-pplev(ig,l+1))/g
+              end do
+           end do
+         end do
+         call zerophys(ngrid,tauref)
+       end if  ! (doubleq)
+      END IF   ! (dust scenario)
+
+c --------------------------------------------------------------------------
+c Column integrated visible optical depth in each point (used for diagnostic)
+c --------------------------------------------------------------------------
+      call zerophys(ngrid*naerkind,tau)
+      do l=1,nlayer
+         do ig=1,ngrid
+               tau(ig,1)=tau(ig,1)+ aerosol(ig,l,1)
+         end do
+      end do
+
+      return
+      end 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.F	(revision 57)
@@ -0,0 +1,59 @@
+      subroutine eofdump(ngrid,nlayer,u,v,t,rho,ps)
+
+      implicit none
+c
+c     Dumps profiles for calculation of variability EOFs 
+c     Modified to include rho, FF 09/2004
+c     Corrected small bug in sampling rate/count, EM 11/2007
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "eofdump.h"
+c
+
+      integer ngrid
+      integer nlayer
+      real*4 u(ngrid,nlayer)
+      real*4 v(ngrid,nlayer)
+      real*4 t(ngrid,nlayer)
+      real*4 rho(ngrid,nlayer)
+      real*4 ps(ngrid)
+      integer count
+      data count /0/
+      save count
+      integer i,j,l, ig
+
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall/.true./
+
+c-------------------------------------------------------
+c     Initialization at first call:
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      IF (firstcall) THEN
+        write(*,*) 'CALL ineofdump'
+        CALL ineofdump
+        firstcall=.false.
+      END IF
+
+c-------------------------------------------------------
+c     Dumps every ieofs physics timesteps
+c
+!      write(*,*)'eofdump:count=',count,' ps(1)=',ps(1)
+!      if ((ieofs.gt.0).and.(mod(count,ieofs).eq.0)) then
+      if (mod(count+1,ieofs).eq.0) then
+!        write(*,*)'eofdump: dump --> ps(1)=',ps(1)
+        do i=1,iim,eofskip
+          do j=1+eofskip/2,jjm+1,eofskip
+            ig = 1+ (j-2)*iim +i
+            write(uedata) (u(ig,l),l=1,nlayer)
+            write(uedata) (v(ig,l),l=1,nlayer)
+            write(uedata) (t(ig,l),l=1,nlayer)
+            write(uedata) (rho(ig,l),l=1,nlayer)
+            write(uedata) ps(ig)
+          enddo
+        enddo
+      endif
+      count=count+1
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/eofdump.h	(revision 57)
@@ -0,0 +1,22 @@
+c
+c  eofdump:
+c	This include file controls the production of data for EOFs.
+c
+c	Dump profiles for EOFs every ieofs physics timesteps,
+c       starting at first call.
+	integer ieofs
+c
+c	Only dump profiles every eofskip points in each direction
+c       on the model grid.
+	integer eofskip
+	parameter (eofskip = 4)
+c
+c	Units for writing EOF header and data
+	integer uehead, uedata
+	parameter (uehead = 82, uedata = 83)
+c
+	common /eofcom/ ieofs
+c
+      INTEGER npgrid
+      PARAMETER(npgrid=ngridmx+2*(iim-1))
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/fisice.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/fisice.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/fisice.h	(revision 57)
@@ -0,0 +1,14 @@
+c-----------------------------------------------------------------------
+c INCLUDE fisice.h
+
+      COMMON/fisice/dqsf,rice,rdust,zcondicea,pclc
+
+      REAL dqsf(nqmx)       ! tendance of tracer on surface (e.g. kg.m-2)
+      REAL rice(ngridmx,nlayermx) ! Estimated ice crystal radius (m)
+      REAL rdust(ngridmx,nlayermx) ! Prescribed dust radius in each layer (m) 
+c Variables used to define water ice scavenging by atmos. CO2 condensing
+      REAL zcondicea(ngridmx,nlayermx)
+c Some diagnostic variables 
+
+      REAL pclc(ngridmx)  ! cloud cover ratio (used by radiative transfer, may depend of nlay in the future)
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/flusv.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/flusv.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/flusv.F	(revision 57)
@@ -0,0 +1,333 @@
+      SUBROUTINE flusv(KDLON,nsf,n,omega,g,tau,emis,bh,bsol,fah,fdh)
+      IMPLICIT NONE
+c.......................................................................
+c
+c  calcul des flux ascendant et descendant aux interfaces entre n couches
+c  * dans l'infrarouge 
+c  * B est une fonction lineaire de $\tau$ a l'interieur de chaque couche
+c  * le B du sol peut etre different de celui qui correspond au profil
+c    de la n-ieme couche
+c  * l'hypothese est une hypothese a deux flux isotropes sur chaque 
+c    hemisphere ("hemispheric constant") + "source function technique"
+c    (voir Toon et al. 1988)
+c  * le flux descendant en haut de l'atmosphere est nul
+c  * les couches sont numerotees du haut de l'atmosphere vers le sol
+c
+c  in :   * KDLON      ---> dimension de vectorisation
+c         * nsf        ---> nsf=0 ==> "hemispheric constant"
+c                           nsf>0 ==> "hemispheric constant" + "source function"
+c         * n          ---> nombre de couches
+c         * omega(i)   ---> single scattering albedo pour la i-eme couche
+c         * g(i)       ---> asymmetry parameter pour la i-eme couche
+c         * tau(i)     ---> epaisseur optique de la i-eme couche
+c         * emis       ---> emissivite du sol
+c         * bh(i)      ---> luminance du corps noir en haut de la i-eme
+c                           couche, bh(n+1) pour la valeur au sol qui
+c                           correspond au profil de la n-ieme couche
+c         * bsol       ---> luminance du corps noir au sol
+c
+c  out :  * fah(i)     ---> flux ascendant en haut de la i-eme couche,
+c                           fah(n+1) pour le sol 
+c         * fdh(i)     ---> flux descendant en haut de la i-eme couche,
+c                           fdh(n+1) pour le sol 
+c
+c.......................................................................
+c  include des dimensions locales
+c 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER KDLON,nsf,n
+      REAL omega(NDLO2,n),g(NDLO2,n),tau(NDLO2,n),emis(NDLO2)
+     &,bh(NDLO2,n+1),bsol(NDLO2),fah(NDLO2,n+1),fdh(NDLO2,n+1)
+c.......................................................................
+c  declaration des variables locales
+c 
+      REAL pi
+      PARAMETER (pi=3.141592653589793E+0)
+      INTEGER iv,i,j
+      REAL beta,gama1,gama2,amu1,grgama,b0,b1
+      REAL a(NDLON,4*nlayermx),b(NDLON,4*nlayermx)
+     &    ,d(NDLON,4*nlayermx),e(NDLON,4*nlayermx)
+     &    ,y(NDLON,4*nlayermx)
+     &    ,alambda(NDLON,2*nlayermx)
+     &    ,e1(NDLON,2*nlayermx),e2(NDLON,2*nlayermx)
+     &    ,e3(NDLON,2*nlayermx),e4(NDLON,2*nlayermx)
+     &    ,cah(NDLON,2*nlayermx),cab(NDLON,2*nlayermx)
+     &    ,cdh(NDLON,2*nlayermx),cdb(NDLON,2*nlayermx)
+      REAL grg(NDLON,2*nlayermx),grh(NDLON,2*nlayermx)
+     &    ,grj(NDLON,2*nlayermx),grk(NDLON,2*nlayermx)
+     &    ,alpha1(NDLON,2*nlayermx),alpha2(NDLON,2*nlayermx)
+     &    ,sigma1(NDLON,2*nlayermx),sigma2(NDLON,2*nlayermx)
+      INTEGER nq
+      PARAMETER (nq=8)
+      REAL x(nq),w(nq),gri(NDLON,nq)
+      DATA x/1.9855071751231860E-2 , 0.1016667612931866E+0
+     &     , 0.2372337950418355E+0 , 0.4082826787521751E+0
+     &     , 0.5917173212478250E+0 , 0.7627662049581645E+0
+     &     , 0.8983332387068134E+0 , 0.9801449282487682E+0/
+      DATA w/5.0614268145185310E-2 , 0.1111905172266872E+0
+     &     , 0.1568533229389437E+0 , 0.1813418916891810E+0
+     &     , 0.1813418916891810E+0 , 0.1568533229389437E+0
+     &     , 0.1111905172266872E+0 , 5.0614268145185310E-2/
+c....................................................................... 
+c
+c....................................................................... 
+      do 10001 i=1,n
+                                                   do 99999 iv=1,KDLON
+      beta=(1.E+0-g(iv,i))/2.E+0
+      gama1=2.E+0*(1.E+0-omega(iv,i)*(1.E+0-beta))
+      gama2=2.E+0*omega(iv,i)*beta
+      amu1=5.E-1
+      alambda(iv,i)=sqrt(gama1**2-gama2**2)
+      grgama=(gama1-alambda(iv,i))/gama2
+c
+c ici une petite bidouille : si l'epaisseur optique d'une couche
+c est trop faible, $dB \over d\tau$ devient tres grand et le schema
+c s'ecroule. dans ces cas, on fait l'hypothese de couche isotherme.
+c
+      if (tau(iv,i).gt.1.E-3) then
+      b0=bh(iv,i)
+      b1=(bh(iv,i+1)-b0)/tau(iv,i)
+      else
+      b0=(bh(iv,i)+bh(iv,i+1))/2.E+0
+      b1=0.E+0
+      endif
+c
+      e1(iv,i)=1.E+0+grgama*exp(-alambda(iv,i)*tau(iv,i))
+      e2(iv,i)=1.E+0-grgama*exp(-alambda(iv,i)*tau(iv,i))
+      e3(iv,i)=grgama+exp(-alambda(iv,i)*tau(iv,i))
+      e4(iv,i)=grgama-exp(-alambda(iv,i)*tau(iv,i))
+      cah(iv,i)=2.E+0*pi*amu1*(b0+b1/(gama1+gama2))
+      cab(iv,i)=2.E+0*pi*amu1*(b0+b1*(tau(iv,i)+1.E+0/(gama1+gama2)))
+      cdh(iv,i)=2.E+0*pi*amu1*(b0-b1/(gama1+gama2))
+      cdb(iv,i)=2.E+0*pi*amu1*(b0+b1*(tau(iv,i)-1.E+0/(gama1+gama2)))  
+c
+      grg(iv,i)=(1.E+0/amu1-alambda(iv,i))
+      grh(iv,i)=grgama*(alambda(iv,i)+1.E+0/amu1)
+      grj(iv,i)=grh(iv,i)
+      grk(iv,i)=grg(iv,i)
+      alpha1(iv,i)=2.E+0*pi*(b0+b1*(1.E+0/(gama1+gama2)-amu1))
+      alpha2(iv,i)=2.E+0*pi*b1
+      sigma1(iv,i)=2.E+0*pi*(b0-b1*(1.E+0/(gama1+gama2)-amu1))
+      sigma2(iv,i)=alpha2(iv,i)
+c
+99999                                              continue
+10001 continue
+c.......................................................................
+                                                   do 99998 iv=1,KDLON
+      a(iv,1)=0.E+0
+      b(iv,1)=e1(iv,1)
+      d(iv,1)=-e2(iv,1)
+      e(iv,1)=-cdh(iv,1)
+99998                                              continue
+c
+      do 10002 i=1,n-1 
+      j=2*i+1
+                                                   do 99997 iv=1,KDLON
+      a(iv,j)=e2(iv,i)*e3(iv,i)-e4(iv,i)*e1(iv,i)
+      b(iv,j)=e1(iv,i)*e1(iv,i+1)-e3(iv,i)*e3(iv,i+1)
+      d(iv,j)=e3(iv,i)*e4(iv,i+1)-e1(iv,i)*e2(iv,i+1)
+      e(iv,j)=e3(iv,i)*(cah(iv,i+1)-cab(iv,i))
+     &       +e1(iv,i)*(cdb(iv,i)-cdh(iv,i+1))
+99997                                              continue
+10002 continue
+c
+      do 10003 i=1,n-1
+      j=2*i
+                                                   do 99996 iv=1,KDLON
+      a(iv,j)=e2(iv,i+1)*e1(iv,i)-e3(iv,i)*e4(iv,i+1)
+      b(iv,j)=e2(iv,i)*e2(iv,i+1)-e4(iv,i)*e4(iv,i+1)
+      d(iv,j)=e1(iv,i+1)*e4(iv,i+1)-e2(iv,i+1)*e3(iv,i+1)
+      e(iv,j)=e2(iv,i+1)*(cah(iv,i+1)-cab(iv,i))
+     &       +e4(iv,i+1)*(cdb(iv,i)-cdh(iv,i+1))
+99996                                              continue
+10003 continue
+c     
+      j=2*n
+                                                   do 99995 iv=1,KDLON
+      a(iv,j)=e1(iv,n)-(1.E+0-emis(iv))*e3(iv,n)
+      b(iv,j)=e2(iv,n)-(1.E+0-emis(iv))*e4(iv,n)
+      d(iv,j)=0.E+0
+      e(iv,j)=emis(iv)*pi*bsol(iv)-cab(iv,n)+(1.E+0-emis(iv))*cdb(iv,n)
+99995                                              continue
+c.......................................................................
+      call sys3v(KDLON,2*n,a,b,d,e,y)
+c....................................................................... 
+      do 10004 i=1,n
+                                                   do 99994 iv=1,KDLON
+      grg(iv,i)=grg(iv,i)*(y(iv,2*i-1)+y(iv,2*i))
+      grh(iv,i)=grh(iv,i)*(y(iv,2*i-1)-y(iv,2*i))
+      grj(iv,i)=grj(iv,i)*(y(iv,2*i-1)+y(iv,2*i))
+      grk(iv,i)=grk(iv,i)*(y(iv,2*i-1)-y(iv,2*i))
+99994                                              continue
+10004 continue
+c.......................................................................
+c les valeurs de flux "hemispheric constant"
+c 
+      IF (nsf.eq.0) THEN
+      do 10005 i=1,n
+                                                   do 99993 iv=1,KDLON
+      fah(iv,i)=e3(iv,i)*y(iv,2*i-1)-e4(iv,i)*y(iv,2*i)+cah(iv,i)
+      fdh(iv,i)=e1(iv,i)*y(iv,2*i-1)-e2(iv,i)*y(iv,2*i)+cdh(iv,i)
+99993                                              continue
+10005 continue
+                                                   do 99992 iv=1,KDLON
+      fah(iv,n+1)=e1(iv,n)*y(iv,2*n-1)+e2(iv,n)*y(iv,2*n)+cab(iv,n)
+      fdh(iv,n+1)=e3(iv,n)*y(iv,2*n-1)+e4(iv,n)*y(iv,2*n)+cdb(iv,n)
+99992                                              continue
+      GOTO 10100
+      ENDIF 
+c....................................................................... 
+c passage a "source function" 
+c 
+c on applique une quadrature de dimension nq
+c x est le vecteur des \mu de la quadrature
+c w est le vecteur des poids correspondants
+c nq est fixe en parameter
+c x et w sont fixes en data
+c 
+c....................................................................... 
+c on part d'en haut et on descent selon les nq angles pour calculer
+c tous les flux descendants 
+c
+      do 10006 j=1,nq 
+                                                   do 99991 iv=1,KDLON
+      gri(iv,j)=0.E+0
+99991                                              continue
+10006 continue
+                                                   do 99990 iv=1,KDLON
+      fdh(iv,1)=0.E+0
+99990                                              continue
+      do 10007 i=1,n
+      do 10008 j=1,nq
+                                                   do 99989 iv=1,KDLON
+      gri(iv,j)=gri(iv,j)*exp(-tau(iv,i)/x(j))
+     &+grj(iv,i)/(alambda(iv,i)*x(j)+1.E+0)
+     &*(1.E+0-exp(-tau(iv,i)*(alambda(iv,i)+1.E+0/x(j))))
+     &+grk(iv,i)/(alambda(iv,i)*x(j)-1.E+0)
+     &*(exp(-tau(iv,i)/x(j))-exp(-tau(iv,i)*alambda(iv,i)))
+     &+sigma1(iv,i)*(1.E+0-exp(-tau(iv,i)/x(j)))
+     &+sigma2(iv,i)*(x(j)*exp(-tau(iv,i)/x(j))+tau(iv,i)-x(j))
+99989                                              continue
+10008 continue
+                                                   do 99988 iv=1,KDLON
+      fdh(iv,i+1)=0.E+0
+99988                                              continue
+      do 10009 j=1,nq 
+                                                   do 99987 iv=1,KDLON
+      fdh(iv,i+1)=fdh(iv,i+1)+w(j)*x(j)*gri(iv,j)
+99987                                              continue
+10009 continue
+10007 continue
+c.......................................................................
+c on applique la condition de reflexion a sol 
+c
+                                                   do 99986 iv=1,KDLON
+      fah(iv,n+1)=(1.E+0-emis(iv))*fdh(iv,n+1)+pi*emis(iv)*bsol(iv)
+99986                                              continue
+      do 10010 j=1,nq
+                                                   do 99985 iv=1,KDLON
+      gri(iv,j)=2.E+0*fah(iv,n+1)
+99985                                              continue
+10010 continue 
+c.......................................................................
+c on remonte pour calculer tous les flux ascendants 
+c  
+      do 10011 i=n,1,-1 
+      do 10012 j=1,nq 
+                                                   do 99984 iv=1,KDLON
+      gri(iv,j)=gri(iv,j)*exp(-tau(iv,i)/x(j))
+     &+grg(iv,i)/(alambda(iv,i)*x(j)-1.E+0)
+     &*(exp(-tau(iv,i)/x(j))-exp(-tau(iv,i)*alambda(iv,i)))
+     &+grh(iv,i)/(alambda(iv,i)*x(j)+1.E+0)
+     &*(1.E+0-exp(-tau(iv,i)*(alambda(iv,i)+1.E+0/x(j))))
+     &+alpha1(iv,i)*(1.E+0-exp(-tau(iv,i)/x(j)))
+     &+alpha2(iv,i)*(x(j)-(tau(iv,i)+x(j))*exp(-tau(iv,i)/x(j)))
+99984                                              continue
+10012 continue
+                                                   do 99983 iv=1,KDLON
+      fah(iv,i)=0.E+0
+99983                                              continue
+      do 10013 j=1,nq 
+                                                   do 99982 iv=1,KDLON
+      fah(iv,i)=fah(iv,i)+w(j)*x(j)*gri(iv,j)
+99982                                              continue
+10013 continue
+10011 continue
+c.......................................................................
+10100 continue      
+c.......................................................................
+c
+c.......................................................................
+      RETURN
+      END
+
+c ***************************************************************
+
+
+      SUBROUTINE sys3v(KDLON,n,a,b,d,e,y)
+      IMPLICIT NONE
+c.......................................................................
+c
+c  inversion d'un systeme lineaire tridiagonal
+c
+c  |  b1  d1               |   | y1 |   | e1 |
+c  |  a2  b2  d2           |   | y2 |   | e2 |
+c  |      a3  b3  d3       | * | y3 | = | e3 |
+c  |             ....      |   |    |   |    |
+c  |              an  bn   |   | yn |   | en |
+c
+c  in :   * KDLON        --> dimension de vectorisation
+c         * n            --> dimension du systeme
+c         * a,b,d,e      --> voir dessin
+c
+c  out :  * y            --> voir dessin
+c
+c.......................................................................
+c  include des dimensions locales
+c 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER KDLON,n
+      REAL a(NDLO2,n),b(NDLO2,n),d(NDLO2,n),e(NDLO2,n),y(NDLO2,n)
+c.......................................................................
+c  declaration des variables locales
+c 
+      INTEGER iv,i
+      REAL as(NDLON,4*nlayermx),ds(NDLON,4*nlayermx)
+     &    ,x(NDLON,4*nlayermx)
+c.......................................................................
+c
+c.......................................................................
+                                                   do 99999 iv=1,KDLON
+      as(iv,n)=a(iv,n)/b(iv,n)
+      ds(iv,n)=e(iv,n)/b(iv,n)
+99999                                              continue
+      do 10001 i=n-1,1,-1
+                                                   do 99998 iv=1,KDLON
+      x(iv,i)=1.E+0/(b(iv,i)-d(iv,i)*as(iv,i+1))
+      as(iv,i)=a(iv,i)*x(iv,i)
+      ds(iv,i)=(e(iv,i)-d(iv,i)*ds(iv,i+1))*x(iv,i)
+99998                                              continue
+10001 continue 
+                                                   do 99997 iv=1,KDLON
+      y(iv,1)=ds(iv,1)
+99997                                              continue
+      do 10002 i=2,n 
+                                                   do 99996 iv=1,KDLON
+      y(iv,i)=ds(iv,i)-as(iv,i)*y(iv,i-1)
+99996                                              continue
+10002 continue
+c.......................................................................
+c
+c.......................................................................
+      RETURN
+      END 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/growthrate.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/growthrate.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/growthrate.F	(revision 57)
@@ -0,0 +1,107 @@
+      subroutine growthrate(timestep,t,p,ph2o,psat,seq,r,Cste)
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c     Determination of the water ice crystal growth rate
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+c
+c   arguments:
+c   ----------
+
+      REAL timestep
+      REAL t    ! temperature in the middle of the layer (K)
+      REAL p    ! pressure in the middle of the layer (K)
+      REAL*8 ph2o ! water vapor partial pressure (Pa)
+      REAL*8 psat ! water vapor saturation pressure (Pa) 
+      REAL r    ! crystal radius before condensation (m)
+      REAL seq  ! Equilibrium saturation ratio
+      REAL dr   ! crystal radius variation (m)
+
+c   local:
+c   ------
+
+      REAL molco2,molh2o
+      REAL Mco2,Mh2o,rho_i,sigh2o
+      REAL nav,rgp,kbz,pi,To
+
+c     Effective gas molecular radius (m)
+      data molco2/2.2e-10/   ! CO2
+c     Effective gas molecular radius (m)
+      data molh2o/1.2e-10/   ! H2O
+c     Molecular weight of CO2
+      data Mco2/44.e-3/            ! kg.mol-1
+c     Molecular weight of H2O
+      data Mh2o/18.e-3/            ! kg.mol-1
+c     surface tension of ice/vapor
+      data sigh2o/0.12/	     ! N.m
+c     Ice density
+      data rho_i/917./        ! kg.m-3 also defined in initcld.f
+c     Avogadro number
+      data nav/6.023e23/
+c     Perfect gas constant
+      data rgp/8.3143/
+c     Boltzman constant
+      data kbz/1.381e-23/
+c     pi number
+      data pi/3.141592654/
+c     Reference temperature, T=273,15 K 
+      data To/273.15/
+
+      REAL k,Lv                 
+      REAL knudsen           ! Knudsen number (gas mean free path/particle radius)
+      REAL a,Dv,lambda       ! Intermediate computations for growth rate
+      REAL*8 Rk,Rd
+      REAL Cste, rf
+
+c-----------------------------------------------------------------------
+c      Ice particle growth rate by diffusion/impegement of water molecules
+c                r.dr/dt = (S-Seq) / (Seq*Rk+Rd)
+c        with r the crystal radius, Rk and Rd the resistances due to 
+c        latent heat release and to vapor diffusion respectively 
+c----------------------------------------------------------------------- 
+
+c     - Equilibrium saturation accounting for KeLvin Effect
+       seq=exp(2*sigh2o*Mh2o/(rho_i*rgp*t*r))
+
+c     - Thermal conductibility of CO2
+      k  = (0.17913 * t - 13.9789) * 4.184e-4
+c     - Latent heat of h2o (J.kg-1)
+      Lv = (2834.3 - 0.28 * (t-To) - 0.004 * (t-To)**2 ) * 1.e+3
+
+c     - Constant to compute gas mean free path
+c     l= (T/P)*a, with a = (  0.707*8.31/(4*pi*molrad**2 * avogadro))
+      a = 0.707*rgp/(4 * pi* molco2**2  * nav)
+
+c     - Compute Dv, water vapor diffusion coefficient
+c       accounting for both kinetic and continuum regime of diffusion,
+c       the nature of which depending on the Knudsen number.
+
+      Dv = 1./3. * sqrt( 8*kbz*t/(pi*Mh2o/nav) )* kbz * t / 
+     &   ( pi * p * (molco2+molh2o)**2 * sqrt(1.+Mh2o/Mco2) )
+
+      knudsen = t / p * a / r
+      lambda  = (1.333+0.71/knudsen) / (1.+1./knudsen)
+      Dv      = Dv / (1. + lambda * knudsen)
+
+c     - Compute Rk
+      Rk = Lv**2 * rho_i * Mh2o / (k*rgp*t**2.)
+c     - Compute Rd
+      Rd = rgp * t *rho_i / (Dv*psat*Mh2o)
+
+c     - Compute Cste=rdr/dt, then r(t+1)= sqrt(r(t)**2.+2.*Cste*dt)
+       Cste = 1. / (seq*Rk+Rd)
+c      Cste = (ph2o/psat-seq) / (seq*Rk+Rd)
+c      rf   = sqrt( max( r**2.+2.*Cste*timestep , 0. ) )
+c      dr   = rf-r
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwprofil.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwprofil.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwprofil.F	(revision 57)
@@ -0,0 +1,216 @@
+      SUBROUTINE GWPROFIL
+     *         ( klon, klev
+     *         , kgwd ,kdx  , ktest
+     *         , KKCRIT, KKCRITH, KCRIT ,  kkenvh, kknu,kknu2
+     *         , PAPHM1, PRHO   , PSTAB , PTFR , PVPH , PRI , PTAU
+     *         , ptauf ,pdmod   , pnu   , psig ,pgamma, pvar      )
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      implicit none
+C
+
+C
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+      integer klon,klev,kidia,kfdia
+#include "yoegwd.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer kgwd
+      INTEGER KKCRIT(NDLO2),KKCRITH(NDLO2),KCRIT(NDLO2)
+     *       ,kdx(NDLO2),ktest(NDLO2)
+     *       ,kkenvh(NDLO2),kknu(NDLO2),kknu2(NDLO2)
+C
+      REAL PAPHM1(NDLO2,klev+1), PSTAB(NDLO2,klev+1),
+     *     PRHO  (NDLO2,klev+1), PVPH (NDLO2,klev+1),
+     *     PRI   (NDLO2,klev+1), PTFR (NDLO2), PTAU(NDLO2,klev+1),
+     *     ptauf (NDLO2,klev+1)
+     
+      REAL pdmod (NDLO2) , pnu (NDLO2) , psig(NDLO2),
+     *     pgamma(NDLO2) , pvar(NDLO2)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+c   declarations pour 'implicit none"
+      real zsqr,zalfa,zriw,zalpha,zb,zdel,zdz2n,zdelp,zdelpt
+
+      integer ji,jk,jl,ilevh
+      REAL ZDZ2 (NDLO2,nlayermx) , ZNORM(NDLO2) , zoro(NDLO2)
+      REAL ZTAU (NDLO2,nlayermx+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+
+
+      kidia=1
+      kfdia=klon
+
+ 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,KKNU(JL)+1)=PTAU(JL,KKNU(JL)+1)
+      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.GE.KKNU2(JL)) THEN
+           PTAU(JL,JK)=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.KKNU2(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.KKNU2(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     write(*,*) 'ptau'
+c     write(*,99) ((ji,ilevh,ptau(ji,ilevh),ji=1,NDLO2),
+c    .                  ilevh=1,nlayermx+1)
+ 99   FORMAT(i3,i3,f15.5)
+
+
+C  REORGANISATION OF THE STRESS PROFILE
+C  IF BREAKING OCCURS AT LOW LEVEL:
+
+      DO 530 ji=1,kgwd
+      jl=kdx(ji)
+      ZTAU(JL,KKENVH(JL))=PTAU(JL,KKENVH(JL))
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+      DO 532 ji=1,kgwd
+      jl=kdx(ji)
+                
+         IF(JK.GT.KKCRITH(JL).AND.JK.LT.KKENVH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKENVH(JL))
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KKENVH(JL))
+          PTAU(JL,JK)=ZTAU(JL,KKENVH(JL)) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KKENVH(JL)) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+ 532  CONTINUE    
+ 
+ 531  CONTINUE        
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwstress.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwstress.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/gwstress.F	(revision 57)
@@ -0,0 +1,134 @@
+      SUBROUTINE GWSTRESS
+     *         (  klon  , klev
+     *         , KKCRIT, KSECT, KKHLIM, KTEST, KKCRITH, KCRIT, kkenvh
+     *         , kknu
+     *         , PRHO  , PSTAB, PVPH  , PVAR ,PVARor, psig  
+     *         , 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 none
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+      integer klon,klev,kidia,kfdia
+
+#include "yoegwd.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KKCRIT(NDLO2),KKCRITH(NDLO2),KCRIT(NDLO2),KSECT(NDLO2),
+     *        KKHLIM(NDLO2),KTEST(NDLO2),KKENVH(NDLO2),KKNU(NDLO2)
+C
+      REAL PRHO(NDLO2,klev+1),PSTAB(NDLO2,klev+1),PTAU(NDLO2,klev+1),
+     *     PVPH(NDLO2,klev+1),PVAR(NDLO2,4),PTFR(NDLO2),
+     *     pgeom1(NDLO2,klev),PVARor(NDLO2)
+C
+      real pd1(NDLO2),pd2(NDLO2),pnu(NDLO2),psig(NDLO2),pgamma(NDLO2)
+      real pdmod(NDLO2)
+C
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      integer jl
+      real zblock,zvar,zeff
+      logical lo
+
+C
+C-----------------------------------------------------------------------
+C
+C*       0.3   FUNCTIONS
+C              ---------
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+
+
+      kidia=1
+      kfdia=klon
+
+
+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
+  
+c        IF(KKENVH(JL).EQ.KLEV)THEN
+         ZBLOCK=0.0 
+c        ELSE
+c         ZBLOCK=(PGEOM1(JL,KKENVH(JL))+PGEOM1(JL,KKENVH(JL)+1))/2./RG          
+c        ENDIF
+      
+        ZVAR=PVAROR(JL)
+        ZEFF=AMAX1(0.,2.*ZVAR-ZBLOCK)
+
+        PTAU(JL,KLEV+1)=PRHO(JL,KLEV+1)*GKDRAG*psig(jl)*ZEFF**2
+     *    /4./ZVAR*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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ineofdump.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ineofdump.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ineofdump.F	(revision 57)
@@ -0,0 +1,71 @@
+      subroutine ineofdump
+
+c._.  subroutine ineofdump(long, lati)
+
+      implicit none
+c
+c     Initialise dumping of profiles for EOF calculations
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comvert.h"
+#include "comcstfi.h"
+#include "comgeomfi.h"
+c
+c._.#include "param2"
+c._.#include "bats"
+c._.#include "outcon"
+c._.#include "phycmn"
+c
+#include "eofdump.h"
+c
+c._.      real*4 long(cols,rows)
+c._.      real*4 lati(cols,rows)
+      integer ig,i,j,l    
+      logical firstcall
+      save firstcall
+
+      data firstcall/.true./
+
+      if (firstcall) then
+         firstcall=.false.
+      endif
+
+c
+c     Set frequency for dumping at once per day
+c
+      ieofs=nint(daysec/dtphys)
+      if (abs(float(ieofs)-daysec/dtphys).gt.1.e-8*daysec)
+     :   stop'In ineofdump:  1 day .ne. n physics timesteps'
+c
+c     Header
+c
+      open(uehead,file='profiles.hdr',form='formatted')
+c._.  write(uehead,*) rntape, kstart, ktotal, itspd, kphysic, refday
+      write(uehead,*) 0.E+0,0,0,ieofs,1,0
+c._.  write(uehead,*) cols, rows, npgrid, nl
+      write(uehead,*) iim,npgrid/iim,npgrid,nlayermx
+
+c._.  do i=1,cols,eofskip
+c._.    do j=1+eofskip/2,rows,eofskip
+c._.      write(uehead,*) long(i,j)*180./pi, lati(i,j)*180./pi
+c._.    enddo
+c._.  enddo
+      do i=1,iim,eofskip
+        do j=1+eofskip/2,jjm+1,eofskip    
+          ig = 1+ (j-2)*iim +i
+          if(j.eq.1) stop 'Problem in ineofdump.F'
+          if(j.eq.jjm+1) stop 'Problem in ineofdump.F'
+          write(uehead,*) long(ig)*180./pi, lati(ig)*180./pi
+c         write(*,*) 'eof grid j=',j,' lat= ', lati(ig)*180./pi
+        enddo
+      enddo
+
+      write(uehead,*) aps
+      write(uehead,*) bps
+      close(uehead)
+c
+c     Main profile file
+c
+      open(uedata,file='profiles.dat',form='unformatted')
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inifis.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inifis.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inifis.F	(revision 57)
@@ -0,0 +1,621 @@
+      SUBROUTINE inifis(ngrid,nlayer,
+     $           day_ini,pdaysec,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   modified: Sebastien Lebonnois 11/06/2003 (new callphys.def)
+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 "dimphys.h"
+#include "planete.h"
+#include "comcstfi.h"
+#include "comsaison.h"
+#include "comdiurn.h"
+#include "comgeomfi.h"
+#include "callkeys.h"
+#include "surfdat.h"
+
+
+      REAL prad,pg,pr,pcpp,pdaysec,ptimestep
+ 
+      INTEGER ngrid,nlayer
+      REAL plat(ngrid),plon(ngrid),parea(ngridmx)
+      integer day_ini
+      INTEGER ig,ierr
+ 
+      EXTERNAL iniorbit,orbite
+      EXTERNAL SSUM
+      REAL SSUM
+ 
+      CHARACTER ch1*12
+      CHARACTER ch80*80
+
+      logical chem, h2o
+
+      rad=prad
+      daysec=pdaysec
+      dtphys=ptimestep
+      cpp=pcpp
+      g=pg
+      r=pr
+      rcp=r/cpp
+
+c --------------------------------------------------------
+c     The usual Tests
+c     --------------
+      IF (nlayer.NE.nlayermx) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'nlayer     = ',nlayer
+         PRINT*,'nlayermx   = ',nlayermx
+         STOP
+      ENDIF
+
+      IF (ngrid.NE.ngridmx) THEN
+         PRINT*,'STOP in inifis'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'ngridmx   = ',ngridmx
+         STOP
+      ENDIF
+
+c --------------------------------------------------------------
+c  Reading the "callphys.def" file controlling some key options
+c --------------------------------------------------------------
+
+      callrad=.true.
+      calldifv=.true.
+      calladj=.true.
+      callcond=.true.
+      callsoil=.true.
+      season=.true.
+      diurnal=.false.
+      lwrite=.false.
+      calllott=.true.
+      iaervar=2
+      iddist=3
+      topdustref=55.
+      OPEN(99,file='callphys.def',status='old',form='formatted'
+     .     ,iostat=ierr)
+      IF(ierr.EQ.0) THEN
+         PRINT*
+         PRINT*
+         PRINT*,'--------------------------------------------'
+         PRINT*,' Parametres pour la physique (callphys.def)'
+         PRINT*,'--------------------------------------------'
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1 
+         READ(99,*) tracer
+         WRITE(*,8000) ch1,tracer
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') diurnal
+         WRITE(*,8000) ch1,diurnal
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') season
+         WRITE(*,8000) ch1,season
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') lwrite
+         WRITE(*,8000) ch1,lwrite
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callstats
+         WRITE(*,8000) ch1,callstats
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calleofdump
+         WRITE(*,8000) ch1,calleofdump
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*,iostat=ierr) iaervar
+         if(ierr.ne.0) stop'Can t read iaervar in callphys.def (old?)'
+         WRITE(*,8001) ch1,iaervar
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iddist
+         WRITE(*,8001) ch1,iddist
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) topdustref
+         WRITE(*,8002) ch1,topdustref
+
+         READ(99,*)
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callrad
+         WRITE(*,8000) ch1,callrad
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callnlte
+         WRITE(*,8000) ch1,callnlte
+         
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callnirco2
+         WRITE(*,8000) ch1,callnirco2
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calldifv
+         WRITE(*,8000) ch1,calldifv
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calladj
+         WRITE(*,8000) ch1,calladj
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callcond
+         WRITE(*,8000) ch1,callcond
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callsoil
+         WRITE(*,8000) ch1,callsoil
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calllott
+         WRITE(*,8000) ch1,calllott
+
+         READ(99,*) 
+         READ(99,*)
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iradia
+         WRITE(*,8001) ch1,iradia
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callg2d
+         WRITE(*,8000) ch1,callg2d
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) rayleigh
+         WRITE(*,8000) ch1,rayleigh
+
+         READ(99,*) 
+         READ(99,*)
+
+c TRACERS:
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) dustbin
+         WRITE(*,8001) ch1,dustbin
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) active
+         WRITE(*,8000) ch1,active
+
+c Test of incompatibility:
+c if active is used, then dustbin should be > 0
+
+         if (active.and.(dustbin.lt.1)) then
+           print*,'if active is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) doubleq
+         WRITE(*,8000) ch1,doubleq
+
+c Test of incompatibility:
+c if doubleq is used, then dustbin should be 1
+
+         if (doubleq.and.(dustbin.ne.1)) then
+           print*,'if doubleq is used, then dustbin should be 1'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) lifting
+         WRITE(*,8000) ch1,lifting
+
+c Test of incompatibility:
+c if lifting is used, then dustbin should be > 0
+
+         if (lifting.and.(dustbin.lt.1)) then
+           print*,'if lifting is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) callddevil
+         WRITE(*,8000) ch1,callddevil
+
+c Test of incompatibility:
+c if dustdevil is used, then dustbin should be > 0
+
+         if (callddevil.and.(dustbin.lt.1)) then
+           print*,'if dustdevil is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) scavenging
+         WRITE(*,8000) ch1,scavenging
+
+c Test of incompatibility:
+c if scavenging is used, then dustbin should be > 0
+
+         if (scavenging.and.(dustbin.lt.1)) then
+           print*,'if scavenging is used, then dustbin should > 0'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) sedimentation
+         WRITE(*,8000) ch1,sedimentation
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iceparty
+         WRITE(*,8000) ch1,iceparty
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) activice
+         WRITE(*,8000) ch1,activice
+
+c Test of incompatibility:
+c if activice is used, then iceparty should be used too
+
+         if (activice.and..not.iceparty) then
+           print*,'if activice is used, iceparty should be used too'
+           stop
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) water
+         WRITE(*,8000) ch1,water
+
+c Test of incompatibility:
+c if iceparty is used, then water should be used too
+
+         if (.not.water) then
+            iceparty = .false. 
+         endif
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) caps
+         WRITE(*,8000) ch1,caps
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) photochem
+         WRITE(*,8000) ch1,photochem
+
+         READ(99,*)
+         READ(99,*)
+
+c THERMOSPHERE
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callthermos
+         WRITE(*,8000) ch1,callthermos
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') thermoswater
+         WRITE(*,8000) ch1,thermoswater
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callconduct
+         WRITE(*,8000) ch1,callconduct
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') calleuv
+         WRITE(*,8000) ch1,calleuv
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callmolvis
+         WRITE(*,8000) ch1,callmolvis
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callmoldiff
+         WRITE(*,8000) ch1,callmoldiff
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') thermochem
+         WRITE(*,8000) ch1,thermochem
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) solarcondate
+         WRITE(*,*) ch1,solarcondate
+
+         if (.not.callthermos) then
+                 thermoswater=.false.          
+                 callconduct=.false.          
+                 calleuv=.false.          
+                 callmolvis=.false.          
+                 callmoldiff=.false.          
+                 thermochem=.false.          
+        end if
+
+c Test of incompatibility:
+c if photochem is used, then water should be used too
+
+         if (photochem.and..not.water) then
+           print*,'if photochem is used, water should be used too'
+           stop
+         endif
+
+c if callthermos is used, then thermoswater should be used too 
+c (if water not used already)
+
+         if (callthermos .and. .not.water) then
+           if (callthermos .and. .not.thermoswater) then
+             print*,'if callthermos is used, water or thermoswater 
+     &               should be used too'
+             stop
+           endif
+         endif
+
+         PRINT*,'--------------------------------------------'
+         PRINT*
+         PRINT*
+      ELSE
+         write(*,*)
+         write(*,*) 'Cannot read file callphys.def. Is it here ?'
+         stop
+      ENDIF
+      CLOSE(99)
+
+8000  FORMAT(t5,a12,l8)
+8001  FORMAT(t5,a12,i8)
+8002  FORMAT(t5,a12,f8.1)
+
+      PRINT*
+      PRINT*,'daysec',daysec
+      PRINT*
+      PRINT*,'The radiative transfer is computed:'
+      PRINT*,'           each ',iradia,' physical time-step'
+      PRINT*,'        or each ',iradia*dtphys,' seconds'
+      PRINT*
+c --------------------------------------------------------------
+c  Managing the Longwave radiative transfer
+c --------------------------------------------------------------
+
+c     In most cases, the run just use the following values :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      callemis=.true.     
+c     ilwd=10*int(daysec/dtphys) ! bug before 22/10/01       
+      ilwd=10*int(daysec/dtphys) 
+      ilwn=2               
+      linear=.true.        
+      ncouche=3
+      alphan=0.4
+      ilwb=2
+      semi=0
+
+c     BUT people working hard on the LW may want to read them in 'radia.def' 
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      OPEN(99,file='radia.def',status='old',form='formatted'
+     .     ,iostat=ierr)
+      IF(ierr.EQ.0) THEN
+         write(*,*) 'Reading radia.def !!!'
+         READ(99,fmt='(a)') ch1
+         READ(99,*) callemis
+         WRITE(*,8000) ch1,callemis
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) iradia
+         WRITE(*,8001) ch1,iradia
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) ilwd
+         WRITE(*,8001) ch1,ilwd
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) ilwn
+         WRITE(*,8001) ch1,ilwn
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) linear
+         WRITE(*,8000) ch1,linear
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) ncouche
+         WRITE(*,8001) ch1,ncouche
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) alphan
+         WRITE(*,*) ch1,alphan
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) ilwb
+         WRITE(*,8001) ch1,ilwb
+
+
+         READ(99,fmt='(a)') ch1
+         READ(99,'(l1)') callg2d
+         WRITE(*,8000) ch1,callg2d
+
+         READ(99,fmt='(a)') ch1
+         READ(99,*) semi
+         WRITE(*,*) ch1,semi
+      end if
+
+c-----------------------------------------------------------------------
+c     Some more initialization:
+c     ------------------------
+
+      CALL SCOPY(ngrid,plon,1,long,1)
+      CALL SCOPY(ngrid,plat,1,lati,1)
+      CALL SCOPY(ngrid,parea,1,area,1)
+      totarea=SSUM(ngridmx,area,1)
+
+      DO ig=1,ngrid
+         sinlat(ig)=sin(plat(ig))
+         coslat(ig)=cos(plat(ig))
+         sinlon(ig)=sin(plon(ig))
+         coslon(ig)=cos(plon(ig))
+      ENDDO
+
+      pi=2.*asin(1.)
+
+c     managing the tracers, and tests:
+c     -------------------------------
+
+      if(tracer) then
+
+c          when photochem is used, nqchem_min is the rank
+c          of the first chemical species
+
+       nqchem_min = 1
+       if (photochem .or. callthermos) then
+         chem = .true.
+        if (doubleq) then
+          nqchem_min = 3
+        else
+          nqchem_min = dustbin+1
+        end if
+       end if
+
+       if (water .or. thermoswater) h2o = .true.
+
+c          TESTS
+
+       print*,'TRACERS:'
+
+       if ((doubleq).and.(h2o).and.
+     $     (chem).and.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,' 3 to ',nqmx-2,': chemistry'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+       endif
+
+       if ((doubleq).and.(h2o).and.
+     $     (chem).and..not.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,' 3 to ',nqmx-1,': chemistry'
+         print*,nqmx,': water vapor'
+       endif
+
+       if ((doubleq).and.(h2o).and.
+     $     .not.(chem).and.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+         if (nqmx.ne.4) then
+           print*,'nqmx should be 4 with these options.'
+		   print*,'(or check callphys.def)'
+           stop
+         endif
+       endif
+
+       if ((doubleq).and.(h2o).and.
+     $     .not.(chem).and..not.(iceparty)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         print*,nqmx,': water vapor'
+         if (nqmx.ne.3) then
+           print*,'nqmx should be 3 with these options...'
+		   print*,'(or check callphys.def)'
+           stop
+         endif
+       endif
+
+       if ((doubleq).and..not.(h2o)) then
+         print*,' 1: dust ; 2: dust (doubleq)'
+         if (nqmx.ne.2) then
+           print*,'nqmx should be 2 with these options...'
+		   print*,'(or check callphys.def)'
+           stop
+         endif
+       endif
+
+       if (.not.(doubleq).and.(h2o).and.
+     $     (chem).and.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqchem_min,' to ',nqmx-2,': chemistry'
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     (chem).and..not.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqchem_min,' to ',nqmx-1,': chemistry'
+         print*,nqmx,': water vapor'
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     .not.(chem).and.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqmx-1,': water ice ; ',nqmx,': water vapor'
+         if (nqmx.ne.(dustbin+2)) then
+           print*,'nqmx should be ',(dustbin+2),
+     $            ' with these options...'
+		   print*,'(or check callphys.def)'
+           stop
+         endif
+       endif
+       if (.not.(doubleq).and.(h2o).and.
+     $     .not.(chem).and..not.(iceparty)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+         endif
+         print*,nqmx,': water vapor'
+         if (nqmx.ne.(dustbin+1)) then
+           print*,'nqmx should be ',(dustbin+1),
+     $            ' with these options...'
+		   print*,'(or check callphys.def)'
+           stop
+         endif
+       endif
+       if (.not.(doubleq).and..not.(h2o)) then
+         if (dustbin.gt.0) then
+           print*,' 1 to ',dustbin,': dust bins'
+           if (nqmx.ne.dustbin) then
+             print*,'nqmx should be ',dustbin,
+     $              ' with these options...'
+             print*,'(or check callphys.def)'
+             stop
+           endif
+         else
+           print*,'dustbin=',dustbin,
+     $            ': tracer should be F with these options...'
+     $           ,'UNLESS you just want to move tracers around '
+         endif
+       endif
+
+      endif
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniorbit.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniorbit.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniorbit.F	(revision 57)
@@ -0,0 +1,102 @@
+      SUBROUTINE iniorbit
+     $     (paphelie,pperiheli,pyear_day,pperi_day,pobliq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:
+c   -------
+c     Frederic Hourdin      22 Fevrier 1991
+c
+c   Objet:
+c   ------
+c    Initialisation du sous programme orbite qui calcule
+c    a une date donnee de l'annee de duree year_day commencant
+c    a l'equinoxe de printemps et dont le perihelie se situe
+c    a la date peri_day, la distance au soleil et la declinaison.
+c
+c   Interface:
+c   ----------
+c   - Doit etre appele avant d'utiliser orbite.
+c   - initialise une partie du common planete.h
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   aphelie       \   aphelie et perihelie de l'orbite
+c   periheli      /   en millions de kilometres.
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c   Arguments:
+c   ----------
+
+      REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq
+
+c   Local:
+c   ------
+
+      REAL zxref,zanom,zz,zx0,zdx
+      INTEGER iter
+
+c-----------------------------------------------------------------------
+
+      pi=2.*asin(1.)
+
+      aphelie =paphelie
+      periheli=pperiheli
+      year_day=pyear_day
+      obliquit=pobliq
+      peri_day=pperi_day
+
+      PRINT*,'Perihelie en Mkm  ',periheli
+      PRINT*,'Aphelise  en Mkm  ',aphelie 
+      PRINT*,'obliquite en degres  :',obliquit
+      unitastr=149.597927
+      e_elips=(aphelie-periheli)/(periheli+aphelie)
+      p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
+
+      print*,'e_elips',e_elips
+      print*,'p_elips',p_elips
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(year_day-pperi_day)/year_day
+      zanom=2.*pi*(zz-nint(zz))
+      zxref=abs(zanom)
+      PRINT*,'zanom  ',zanom
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
+c  methode de Newton
+
+      zx0=zxref+e_elips*sin(zxref)
+      DO 110 iter=1,100
+         zdx=-(zx0-e_elips*sin(zx0)-zxref)/(1.-e_elips*cos(zx0))
+         if(abs(zdx).le.(1.e-12)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+      PRINT*,'zx0   ',zx0
+
+c zteta est la longitude solaire
+
+      timeperi=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+      PRINT*,'longitude solaire du perihelie timeperi = ',timeperi
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inistats.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inistats.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/inistats.F	(revision 57)
@@ -0,0 +1,112 @@
+      subroutine inistats(ierr)
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+      integer,intent(out) :: ierr
+      integer :: nid
+      integer :: l,nsteppd
+      real, dimension(llm) ::  sig_s
+      integer :: idim_lat,idim_lon,idim_llm,idim_llmp1,idim_time
+      real, dimension(istime) :: lt
+      integer :: nvarid
+
+      write (*,*) 
+      write (*,*) '                        || STATS ||'
+      write (*,*) 
+      write (*,*) 'daysec',daysec
+      write (*,*) 'dtphys',dtphys
+      nsteppd=nint(daysec/dtphys)
+      write (*,*) 'nsteppd=',nsteppd
+      if (abs(float(nsteppd)-daysec/dtphys).gt.1.e-8*daysec)
+     ,   stop'Dans Instat:  1jour .ne. n pas physiques'
+
+      if(mod(nsteppd,istime).ne.0)
+     ,   stop'Dans Instat:  1jour .ne. n*istime pas physiques'
+
+      istats=nsteppd/istime
+      write (*,*) 'istats=',istats
+      write (*,*) 'Storing ',istime,'times per day'
+      write (*,*) 'thus every ',istats,'physical timestep '
+      write (*,*) 
+
+      do l= 1, llm
+         sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+         pseudoalt(l)=-10.*log(presnivs(l)/preff)   
+      enddo
+
+      ierr = NF_CREATE("stats.nc",NF_CLOBBER,nid)
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_lat)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_lon)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid, "llmp1", llm+1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_time)
+
+      ierr = NF_ENDDEF(nid)
+      call def_var(nid,"Time","Time",
+     .            "days since 0000-00-0 00:00:00",1,
+     .            idim_time,nvarid,ierr)
+! Time is initialised later by mkstats subroutine
+
+      call def_var(nid,"latitude","latitude","degrees_north",1,
+     .            idim_lat,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+      call def_var(nid,"longitude","East longitude","degrees_east",1,
+     .            idim_lon,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+
+! Niveaux verticaux, aps et bps
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"altitude", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"altitude", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",8,"altitude")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif 
+      call def_var(nid,"aps","hybrid pressure at midlayers"," ",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+
+      call def_var(nid,"bps","hybrid sigma at midlayers"," ",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else 
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+
+      ierr=NF_CLOSE(nid)
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/initracer.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/initracer.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/initracer.F	(revision 57)
@@ -0,0 +1,302 @@
+      SUBROUTINE initracer(qsurf,co2ice)
+
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Initialisation related to tracer 
+c (transported dust, water, chemical species, ice...)
+c
+c   Name of the tracer
+c
+c   Test of dimension :
+c   Initialise COMMON tracer in tracer.h
+c
+c   If water=T : q(iq=nqmx) is the water mass mixing ratio
+c   If water=T and iceparty=T : q(iq=nqmx-1) is the ice mass mixing ratio
+
+c   If there is transported dust, it uses iq=1 to iq=dustbin
+c   If there is no transported dust : dustbin=0
+c   If doubleq=T : q(iq=1) is the dust mass mixing ratio
+c                  q(iq=2) is the dust number mixing ratio 
+
+c   If (photochem.or.thermochem) there is "ncomp" chemical species (ncomp
+c   is set in aeronomars/chimiedata.h) using the ncomp iq values starting at
+c      iq=nqchem_min = dustbin+1   (nqchem_min is defined in inifis.F)
+c   
+c
+c   author: F.Forget
+c   ------
+c    Modifs: Franck Montmessin, Sebastien Lebonnois (june 2003)
+c
+c=======================================================================
+
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "tracer.h"
+
+#include "comgeomfi.h"
+#include "watercap.h"
+#include "aerice.h"
+#include "fisice.h"
+#include "chimiedata.h"
+
+
+      real qsurf(ngridmx,nqmx)       ! tracer on surface (e.g.  kg.m-2)
+      real co2ice(ngridmx)           ! co2 ice mass on surface (e.g.  kg.m-2)
+      integer iq,ig
+      real r0_lift , reff_lift
+
+c-----------------------------------------------------------------------
+c  radius(nqmx)      ! aerosol particle radius (m)
+c  rho_q(nqmx)       ! tracer densities (kg.m-3)
+c  qext(nqmx)        ! Single Scat. Extinction coeff at 0.67 um
+c  alpha_lift(nqmx)  ! saltation vertical flux/horiz flux ratio (m-1)
+c  alpha_devil(nqmx) ! lifting coeeficient by dust devil
+c  rho_dust          ! Mars dust density
+c  rho_ice           ! Water ice density
+c  doubleq           ! if method with mass (iq=1) and number(iq=2) mixing ratio
+c  varian            ! Characteristic variance of log-normal distribution
+c-----------------------------------------------------------------------
+
+
+c------------------------------------------------------------
+c     Test Dimensions tracers
+c------------------------------------------------------------
+
+      if(photochem.or.thermochem) then
+          if (iceparty) then
+              if ((nqchem_min+ncomp+1).ne.nqmx) then
+                 print*,'********* Dimension problem! ********'
+                 print*,"nqchem_min+ncomp+1).ne.nqmx"
+                 print*,"ncomp: ",ncomp
+                 print*,"nqchem_min: ",nqchem_min
+                 print*,"nqmx: ",nqmx
+                 print*,'Change ncomp in chimiedata.h'
+               endif
+          else
+               if ((nqchem_min+ncomp).ne.nqmx) then
+                 print*,'********* Dimension problem! ********'
+                 print*,"nqchem_min+ncomp).ne.nqmx"
+                 print*,"ncomp: ",ncomp
+                 print*,"nqchem_min: ",nqchem_min
+                 print*,"nqmx: ",nqmx
+                 print*,'Change ncomp in chimiedata.h'
+                 STOP
+               endif
+            endif
+          endif
+
+c------------------------------------------------------------
+c         NAME and molar mass of the tracer 
+c------------------------------------------------------------
+
+c noms and mmol vectors:
+      if (water) then 
+         mmol(nqmx) = 18.
+         noms(nqmx)   = 'h2o'
+      end if
+      if (iceparty) then
+         noms(nqmx-1) = 'ice'
+         mmol(nqmx-1) = 18.
+      end if
+      if(photochem.or.thermochem) then
+         do iq=nqchem_min, nqchem_min+ncomp-1
+             noms(iq) = nomchem(iq-nqchem_min+1)
+             mmol(iq) = mmolchem(iq-nqchem_min+1)
+         enddo
+      end if
+      if (dustbin.ge.1) then
+          do iq=1,dustbin
+            noms(iq) = 'dust'
+            mmol(iq) = 100.
+          enddo
+          if (doubleq) then
+           noms(1) = 'dust mass mix. ratio'
+           noms(dustbin) = 'dust number mix. ratio'
+          end if
+      end if
+
+c     Simulation of CO2 + neutral gaz
+      if ((dustbin.eq.0).and.(.not.water)) then
+         noms(1) = 'co2'
+         mmol(1) = 44
+         if (nqmx.eq.2)then
+            noms(nqmx) = 'Ar_N2'
+            mmol(nqmx) = 30
+         end if 
+      end if 
+   
+
+c------------------------------------------------------------
+c     Initialisation tracers ....
+c------------------------------------------------------------
+      call zerophys(nqmx,rho_q)
+
+      rho_dust=2500.  ! Mars dust density (kg.m-3)
+      rho_ice=920.    ! Water ice density (kg.m-3)
+
+      if (doubleq) then
+c       "doubleq" technique 
+c       -------------------
+c      (transport of mass and number mixing ratio)
+c       iq=1: Q mass mixing ratio, iq=2: N number mixing ratio
+
+        if( (nqmx.lt.2).or.(water.and.(nqmx.lt.3)) ) then
+            write(*,*) 'nqmx is too low : nqmx=', nqmx
+            write(*,*) 'water= ',water,' doubleq= ',doubleq   
+        end if
+
+        varian=0.637    ! Characteristic variance    
+        qext(1)=3.04    ! reference extinction at 0.67 um for ref dust
+        qext(2)=3.04    ! reference extinction at 0.67 um for ref dust
+        rho_q(1)=rho_dust
+        rho_q(2)=rho_dust
+
+c       Intermediate calcul for computing geometric mean radius r0
+c       as a function of mass and number mixing ratio Q and N
+c       (r0 = (r3n_q * Q/ N)
+        r3n_q = exp(-4.5*varian**2)*(3./4.)/(pi*rho_dust)
+
+c       Intermediate calcul for computing effective radius reff
+c       from geometric mean radius r0
+c       (reff = ref_r0 * r0)
+        ref_r0 = exp(2.5*varian**2)
+        
+c       lifted dust :
+c       '''''''''''
+        reff_lift = 3.e-6      !  Effective radius of lifted dust (m)
+        alpha_devil(1)=9.e-9   !  dust devil lift mass coeff
+        alpha_lift(1)=3.0e-15  !  Lifted mass coeff
+
+        r0_lift = reff_lift/ref_r0
+        alpha_devil(2)= r3n_q * alpha_devil(1)/r0_lift**3
+        alpha_lift(2)= r3n_q * alpha_lift(1)/r0_lift**3
+
+c       Not used:
+        radius(1) = 0.
+	radius(2) = 0.
+
+      else
+
+       if (dustbin.gt.1) then
+        print*,'ATTENTION:',
+     $   ' properties of dust need input in initracer !!!'
+	stop
+
+       else if (dustbin.eq.1) then
+
+c       This will be used for 1 dust particle size:
+c       ------------------------------------------
+        radius(1)=3.e-6
+        Qext(1)=3.04
+        alpha_lift(1)=0.0e-6
+        alpha_devil(1)=7.65e-9
+	    qextrhor(1)= (3./4.)*Qext(1) / (rho_dust*radius(1))
+        rho_q(1)=rho_dust
+
+       endif
+      end if    ! (doubleq)
+
+c     Initialization for photochemistry:
+c     ---------------------------------
+      if (photochem) then
+        do iq=nqchem_min,nqmx
+	 radius(iq)=0.
+         Qext(iq)=0.
+         alpha_lift(iq) =0.
+         alpha_devil(iq)=0.
+	 qextrhor(iq)= 0.
+        enddo
+      endif
+
+c     Initialization for water vapor
+c     ------------------------------
+      if(water) then
+         radius(nqmx)=0.
+         Qext(nqmx)=0.
+         alpha_lift(nqmx) =0.
+         alpha_devil(nqmx)=0.
+	 qextrhor(nqmx)= 0.
+
+c       "Dryness coefficient" controlling the evaporation and
+c        sublimation from the ground water ice (close to 1)
+c        HERE, the goal is to correct for the fact
+c        that the simulated permanent water ice polar caps
+c        is larger than the actual cap and the atmospheric
+c        opacity not always realistic.
+
+         do ig=1,ngridmx
+           if (ngridmx.ne.1) watercaptag(ig)=.false.
+           dryness(ig) = 1.
+           if (activice) pclc(ig)=1.
+         enddo
+
+         IF (caps) THEN
+c Perennial H20 north cap defined by watercaptag=true (allows surface to be
+c hollowed by sublimation in vdifc).
+c Cloud area fraction (pclc) is defined here.
+         do ig=1,ngridmx
+           if (lati(ig)*180./pi.gt.84) then
+             if (ngridmx.ne.1) watercaptag(ig)=.true.
+             dryness(ig) = 1.
+             if (activice)then
+               pclc(ig)=1.
+               print*,'Cloud area ratio : ',pclc(ig),' at lat '
+     $        ,lati(ig)*180./pi
+             endif
+c Use the following cap definition for high spatial resolution (latitudinal bin <= 5 deg)
+c	      if (lati(ig)*180./pi.lt.85.and.long(ig).ge.0) then
+c	        if (ngridmx.ne.1) watercaptag(ig)=.true.
+c	        pclc(ig)=.3
+c               dryness(ig) = 1.
+c               print*,'Cloud area ratio : ',pclc(ig),' at lat '
+c	      endif
+c             if (lati(ig)*180./pi.ge.85) then
+c               if (ngridmx.ne.1) watercaptag(ig)=.true.
+c               dryness(ig) = 1.
+c	        pclc(ig)=.3
+c               print*,'Cloud area ratio : ',pclc(ig),' at lat '
+c	      endif
+           endif  ! (lati>80 deg)
+         end do ! (ngridmx)
+        ENDIF ! (caps)
+
+         if(iceparty.and.nqmx.ge.2) then
+           radius(nqmx-1)=3.e-6
+           rho_q(nqmx-1)=rho_ice
+           Qext(nqmx-1)=0.
+           alpha_lift(nqmx-1) =0.
+           alpha_devil(nqmx-1)=0.
+           if (activice) then
+             radius(nqmx-1)=rcrystal
+             Qext(nqmx-1)=qrefice
+           endif
+           qextrhor(nqmx-1)= (3./4.)*Qext(nqmx-1) 
+     $       / (rho_ice*radius(nqmx-1))
+         elseif(iceparty.and.nqmx.lt.2) then
+            write(*,*) 'nqmx is too low : nqmx=', nqmx
+            write(*,*) 'water= ',water,' iceparty= ',iceparty
+         endif
+
+      end if  ! (water)
+
+c     Output for records:
+c     ~~~~~~~~~~~~~~~~~~
+      write(*,*)
+      Write(*,*) '******** initracer : dust transport parameters :'
+      write(*,*) 'alpha_lift = ', alpha_lift
+      write(*,*) 'alpha_devil = ', alpha_devil
+      write(*,*) 'radius  = ', radius
+      if(doubleq) then
+        write(*,*) 'reff_lift (um) =  ', reff_lift
+        write(*,*) 'size distribution variance  = ', varian
+        write(*,*) 'r3n_q , ref_r0 : ', r3n_q , ref_r0
+      end if
+      write(*,*) 'Qext  = ', qext 
+      write(*,*)
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniwrite.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniwrite.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/iniwrite.F	(revision 57)
@@ -0,0 +1,333 @@
+      SUBROUTINE iniwrite(nid,idayref,phis)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:  L. Fairhead  ,  P. Le Van, Y. Wanherdrick, F. Forget
+c   -------
+c
+c   Objet:
+c   ------
+c
+c   'Initialize' the diagfi.nc file: write down dimensions as well
+c   as time-independent fields (e.g: geopotential, mesh area, ...)
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comcstfi.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "temps.h"
+#include "ener.h"
+#include "logic.h"
+#include "netcdf.inc"
+#include "description.h"
+#include "serre.h"
+#include"dimphys.h"
+
+c   Arguments:
+c   ----------
+
+      integer nid        ! NetCDF file ID
+      INTEGER*4 idayref  ! date (initial date for this run)
+      REAL phis(ip1jmp1) ! surface geopotential
+
+c   Local:
+c   ------
+      INTEGER length,l
+      parameter (length = 100)
+      REAL tab_cntrl(length) ! run parameters are stored in this array
+      INTEGER ierr
+
+      integer :: nvarid,idim_index,idim_rlonu,idim_rlonv
+      integer :: idim_rlatu,idim_rlatv,idim_llmp1,idim_llm
+      integer, dimension(2) :: id  
+c-----------------------------------------------------------------------
+
+      DO l=1,length
+         tab_cntrl(l)=0.
+      ENDDO
+      tab_cntrl(1)  = FLOAT(iim)
+      tab_cntrl(2)  = FLOAT(jjm)
+      tab_cntrl(3)  = FLOAT(llm)
+      tab_cntrl(4)  = FLOAT(idayref)
+      tab_cntrl(5)  = rad
+      tab_cntrl(6)  = omeg
+      tab_cntrl(7)  = g
+      tab_cntrl(8)  = mugaz
+      tab_cntrl(9)  = rcp
+      tab_cntrl(10) = daysec
+      tab_cntrl(11) = dtphys
+      tab_cntrl(12) = etot0
+      tab_cntrl(13) = ptot0
+      tab_cntrl(14) = ztot0
+      tab_cntrl(15) = stot0
+      tab_cntrl(16) = ang0
+c
+c    ..........    P.Le Van  ( ajout le 8/04/96 )    .........
+c         .....        parametres  pour le zoom          ......   
+      tab_cntrl(17)  = clon
+      tab_cntrl(18)  = clat
+      tab_cntrl(19)  = grossismx
+      tab_cntrl(20)  = grossismy
+c
+c     .....   ajout  le 6/05/97 et le 15/10/97  .......
+c
+      IF ( fxyhypb )   THEN
+        tab_cntrl(21) = 1.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+      ELSE
+        tab_cntrl(21) = 0.
+        tab_cntrl(22) = dzoomx
+        tab_cntrl(23) = dzoomy
+        tab_cntrl(24) = 0.
+        IF( ysinus )  tab_cntrl(24) = 1.
+      ENDIF
+
+c    .........................................................
+
+! Define dimensions
+    
+      ierr = NF_REDEF (nid)
+
+      ierr = NF_DEF_DIM (nid, "index", length, idim_index)
+      ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu)
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv)
+      ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv)
+      ierr = NF_DEF_DIM (nid, "interlayer", (llm+1), idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+c
+      ierr = NF_ENDDEF(nid)
+
+c  Contol parameters for this run
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, 
+     .       idim_index,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, 
+     .       idim_index,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18,
+     .                       "Control parameters")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl)
+#endif
+
+c --------------------------
+c  longitudes and latitudes
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rlonu", NF_DOUBLE, 1, idim_rlonu,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rlonu", NF_FLOAT, 1, idim_rlonu,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 21,
+     .                       "Longitudes at u nodes")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid, "latitude", NF_DOUBLE, 1, idim_rlatu,nvarid)
+#else
+      ierr =NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim_rlatu,nvarid)
+#endif
+      ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "North latitude")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid)
+#else
+      ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14,
+     .      "East longitude")
+      ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1, 
+     .       idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1, 
+     .       idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "rlatv", NF_DOUBLE, 1, idim_rlatv,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "rlatv", NF_FLOAT, 1, idim_rlatv,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 20,
+     .                       "Latitudes at v nodes")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv/pi*180)
+#endif
+c
+c --------------------------
+c  Vertical levels
+      call def_var(nid,"aps","hybrid pressure at midlayers ","Pa",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+#endif
+
+      call def_var(nid,"bps","hybrid sigma at midlayers"," ",
+     .            1,idim_llm,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+#endif
+
+      call def_var(nid,"ap","hybrid pressure at interlayers","Pa",
+     .            1,idim_llmp1,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,ap)
+#endif
+
+      call def_var(nid,"bp","hybrid sigma at interlayers"," ",
+     .            1,idim_llmp1,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,bp)
+#endif
+
+c
+c --------------------------
+c  Mesh area and conversion coefficients cov. <-> contra. <--> natural
+
+      id(1)=idim_rlonu
+      id(2)=idim_rlatu
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "cu", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "cu", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 40,
+     .             "Conversion coefficients cov <--> natural")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cu)
+#endif
+c
+      id(1)=idim_rlonv
+      id(2)=idim_rlatv
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "cv", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "cv", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 40,
+     .             "Conversion coefficients cov <--> natural")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,cv)
+#endif
+c
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+c
+c --------------------------
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "aire", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "aire", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9,
+     .                       "Mesh area")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,aire)
+#endif
+c
+c  Surface geopotential
+      id(1)=idim_rlonv
+      id(2)=idim_rlatu
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "phisinit", NF_DOUBLE, 2, id,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "phisinit", NF_FLOAT, 2, id,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 27,
+     .                       "Geopotential at the surface")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phis)
+#endif
+c
+
+      write(*,*)'iniwrite: iim,jjm,llm,idayref',iim,jjm,llm,idayref
+      write(*,*)'iniwrite: rad,omeg,g,mugaz,rcp',
+     s rad,omeg,g,mugaz,rcp
+      write(*,*)'iniwrite: daysec,dtphys',daysec,dtphys
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismax.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismax.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismax.F	(revision 57)
@@ -0,0 +1,20 @@
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismin.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismin.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/ismin.F	(revision 57)
@@ -0,0 +1,20 @@
+      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
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwb.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwb.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwb.F	(revision 57)
@@ -0,0 +1,140 @@
+      subroutine lwb (kdlon,kflev,tlev,tlay,dt0
+     .               ,bsurf,btop,blay,blev,dblay,dbsublay)
+ 
+c----------------------------------------------------------------------
+c     LWB  computes the planck function and gradient
+c          from a polynomial development of planck function
+c----------------------------------------------------------------------
+
+      implicit none
+ 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+
+#include "yomlw.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer kdlon            ! part of ngrid
+      integer kflev            ! part of nalyer
+
+      real dt0 (ndlo2)                 ! surface temperature discontinuity
+      real tlay (ndlo2,kflev)          ! layer temperature
+      real tlev (ndlo2,kflev+1)        ! level temperature
+
+c                                                            outputs:
+c                                                            --------
+      real bsurf (ndlo2,nir)        ! surface spectral planck function
+      real btop (ndlo2,nir)         ! top spectral planck function
+      real blev (ndlo2,nir,kflev+1) ! level   spectral planck function
+      real blay (ndlo2,nir,kflev)   ! layer   spectral planck function
+      real dblay (ndlo2,nir,kflev)  ! layer gradient spectral planck function
+      real dbsublay (ndlo2,nir,2*kflev)  ! layer gradient spectral planck
+                                         ! function in sub layers
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer jk, jl, jnu, jk1, jk2
+
+      real ztlay (ndlon)
+      real ztlev (ndlon)
+
+c----------------------------------------------------------------------
+      do jnu=1,nir
+c----------------------------------------------------------------------
+c         1.1   levels and layers from surface to nlaylte
+c               ---------------------------------------
+
+      do jk = 1 , nlaylte
+        do jl = 1 , kdlon
+
+c                                                  level planck function 
+c                                                  ---------------------
+      ztlev(jl)=(tlev(jl,jk)-tstand)/tstand    ! tstand = 200k
+
+      blev(jl,jnu,jk)   = xp(1,jnu)
+     .                    +ztlev(jl)*(xp(2,jnu) 
+     .                    +ztlev(jl)*(xp(3,jnu) 
+     .                    +ztlev(jl)*(xp(4,jnu) 
+     .                    +ztlev(jl)*(xp(5,jnu)
+     .                    +ztlev(jl)*(xp(6,jnu)    )))))
+
+c                                                  layer planck function 
+c                                                  ---------------------
+      ztlay(jl)=(tlay(jl,jk)-tstand)/tstand
+
+      blay(jl,jnu,jk) = xp(1,jnu)
+     .                  +ztlay(jl)*(xp(2,jnu)
+     .                  +ztlay(jl)*(xp(3,jnu)
+     .                  +ztlay(jl)*(xp(4,jnu)
+     .                  +ztlay(jl)*(xp(5,jnu)
+     .                  +ztlay(jl)*(xp(6,jnu)    )))))
+
+c                                               planck function gradient
+c                                               ------------------------
+      dblay(jl,jnu,jk) = xp(2,jnu)
+     .                   +ztlay(jl)*(2*xp(3,jnu)
+     .                   +ztlay(jl)*(3*xp(4,jnu)
+     .                   +ztlay(jl)*(4*xp(5,jnu)
+     .                   +ztlay(jl)*(5*xp(6,jnu)  ))))
+      dblay(jl,jnu,jk) = dblay(jl,jnu,jk)/tstand
+
+        enddo
+      enddo
+     
+c----------------------------------------------------------------------
+c         1.2   top of the atmosphere and surface
+c               --------------------------------
+
+      do jl = 1 , kdlon
+c                                                  top of the atmosphere
+c                                                  ---------------------
+      ztlev(jl) = (tlev(jl,nlaylte+1)-tstand)/tstand
+
+      blev(jl,jnu,nlaylte+1) = xp(1,jnu)
+     .                       +ztlev(jl)*(xp(2,jnu)
+     .                       +ztlev(jl)*(xp(3,jnu)
+     .                       +ztlev(jl)*(xp(4,jnu)
+     .                       +ztlev(jl)*(xp(5,jnu)
+     .                       +ztlev(jl)*(xp(6,jnu)    )))))
+      btop(jl,jnu) = blev(jl,jnu,nlaylte+1)
+
+c                                                                surface
+c                                                                -------
+      ztlay(jl) = (tlev(jl,1)+dt0(jl)-tstand)/tstand
+
+      bsurf(jl,jnu) = xp(1,jnu)
+     .               +ztlay(jl)*(xp(2,jnu)
+     .               +ztlay(jl)*(xp(3,jnu)
+     .               +ztlay(jl)*(xp(4,jnu)
+     .               +ztlay(jl)*(xp(5,jnu)
+     .               +ztlay(jl)*(xp(6,jnu)     )))))
+
+      enddo
+
+c----------------------------------------------------------------------
+c         1.3   Gradients in sub-layers
+c               -----------------------
+
+      do jk=1,nlaylte
+        jk2 = 2 * jk
+        jk1 = jk2 - 1 
+          do jl=1,kdlon
+            dbsublay(jl,jnu,jk1)=blay(jl,jnu,jk)-blev(jl,jnu,jk)
+            dbsublay(jl,jnu,jk2)=blev(jl,jnu,jk+1)-blay(jl,jnu,jk)
+          enddo
+      enddo
+
+c----------------------------------------------------------------------
+      enddo           ! (do jnu=1,nir)
+c----------------------------------------------------------------------
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwdiff.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwdiff.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwdiff.F	(revision 57)
@@ -0,0 +1,219 @@
+      subroutine lwdiff (kdlon,kflev
+     .         ,pbsur,pbtop,pdbsl
+     .         ,tautotal,omegtotal,gtotal
+     .         ,pemis,pfluc)
+
+      IMPLICIT NONE
+ 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+
+#include "yomaer.h"
+#include "yomlw.h"
+C-----------------------------------------------------------------------
+C
+c  ABSORPTION ET DIFUSION HORS DE LA BANDE A 15 MICRONS :
+c! 1) Dans la bande a 15 micron (CO2), les poussieres 
+c! n'interviennent que comme un milieu gris non diffusif avec 
+c!                      Q=Qext*(1-Omega)
+c! cette bande est decoupee en deux sous bandes (indices 1 et 2)
+c! pour lesquelles les parametres optiques des poussieres sont
+c! identiques
+c! 2)  le reste est decoupe en "nir-2" bandes : une bande qui recouvre toutes
+c! les longueurs d'onde inferieures a celles de la bande a 15 microns
+c! (indice 3) et nir-3 bandes pour les grandes longueurs d'onde
+c! (indices 4...nir) sur chacune de ces  bandes, les poussieres
+c! sont supposees diffusantes grises.
+c!
+C
+C-----------------------------------------------------------------------
+C
+C
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer kdlon,kflev
+      REAL PBSUR(NDLO2,nir), PBTOP(NDLO2,nir)
+     S  ,  PDBSL(NDLO2,nir,KFLEV*2), PEMIS(NDLO2)
+
+      real PFLUC(NDLO2,2,KFLEV+1)
+      real tautotal(ndlon,nflev,nir)
+      real omegtotal(ndlon,nflev,nir), gtotal(ndlon,nflev,nir)
+
+C
+C
+C-------------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+C
+      integer jl, jk, ndd, indd, iir, j1
+      integer  j2, j2dd2, j2dd1,j2bot,j2top, j2dd
+      REAL ZADJD(NDLON,NFLEV+1), ZADJU(NDLON,NFLEV+1)
+     S  ,  ZDBDT(NDLON,nir,NFLEV)
+     S  ,  ZDISD(NDLON,NFLEV+1), ZDISU(NDLON,NFLEV+1)
+     S  ,  ZFD(NDLON), ZFDN(NDLON,NFLEV+1), ZFU(NDLON)
+     S  ,  ZFUP(NDLON,NFLEV+1),ZGLAYD(NDLON),ZGLAYU(NDLON)
+     S  ,  ZOMEGADD(NDLON,NFLEV*2),ZGDD(NDLON,NFLEV*2)
+     S  ,  ZTAUDD(NDLON,NFLEV*2)
+     S  ,  ZBHDD(NDLON,NFLEV*2+1),ZBSDD(NDLON)
+     S  ,  ZZBHDD(NDLON,NFLEV*2+1),ZZBSDD(NDLON)
+     S  ,  ZFAHDD(NDLON,NFLEV*2+1),ZFDHDD(NDLON,NFLEV*2+1)
+     S  ,  ZZFAHDD(NDLON,NFLEV*2+1),ZZFDHDD(NDLON,NFLEV*2+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+
+      do jl = 1 , kdlon
+        do jk = 1 , nlaylte
+          PFLUC(jl,1,jk) = 0.
+          PFLUC(jl,2,jk) = 0.
+        enddo
+      enddo
+
+      DO 112 JK = 1 , nlaylte+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
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+C     ------------------------------------------------------------------
+C
+C
+C  ==================================================================
+C*         2.0     contribution des bandes "hors co2"
+C  ==================================================================
+C
+ 200  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.0.1   preparation des Planck a chaque hauteur
+C                  ----------------------------------
+C
+c!
+c! le nombre de couche pour la diffusion sera le nombre de layer * 2
+c! soit NDD=nlaylte*2, donc la taille du vecteur des Planck sera
+c! nlaylte*2 + 1. la taille des vecteurs omega / g / tau sera
+c! par contre nlaylte*2 (voir dans FLUSV.F).
+c!
+      NDD=nlaylte*2
+      DO indd=1,ndd+1
+                                            do jl=1,kdlon
+         ZFAHDD(jl,indd)=0.
+         ZFDHDD(jl,indd)=0.
+         ZBHDD(jl,indd)=0.
+                                            enddo
+      ENDDO
+                                            do jl=1,kdlon
+      ZBSDD(jl)=0.
+                                            enddo
+c!
+c! boucle sur les  bandes hors CO2
+c!
+      DO 10001 iir=3,nir
+c!
+                                            do jl=1,kdlon
+        ZZBHDD(JL,1)=PBTOP(JL,iir)/pi
+                                            enddo
+        DO J1=2,NDD+1
+                                            do jl=1,kdlon
+           ZZBHDD(JL,J1)=
+     &     ZZBHDD(JL,J1-1)-PDBSL(JL,iir,NDD-J1+2)/pi
+                                            enddo
+        ENDDO
+                                            do jl=1,kdlon
+        ZZBSDD(JL)=PBSUR(JL,iir)/pi
+                                            enddo
+
+C
+C     ------------------------------------------------------------------
+C
+C*         2.0.2   preparation des coefficients de diffusion
+C                  -----------------------------------------
+C
+c! les omega, g, tau ... boucle de bas en haut
+        DO J2=1,nlaylte-1
+          J2DD2=(nlaylte-J2+1)*2
+          J2DD1=J2DD2-1
+          J2BOT=3*J2-2
+          J2TOP=3*J2+1
+          do jl=1,kdlon
+            ZTAUDD(JL,J2DD1)=tautotal(jl,J2,iir)*0.5
+            ZTAUDD(JL,J2DD2)=ZTAUDD(JL,J2DD1)
+            ZOMEGADD(JL,J2DD1)=omegtotal(jl,J2,iir)
+            ZOMEGADD(JL,J2DD2)=omegtotal(jl,J2,iir)
+            ZGDD(JL,J2DD1)=gtotal(jl,J2,iir)
+            ZGDD(JL,J2DD2)=gtotal(jl,J2,iir)
+          enddo
+        ENDDO
+        J2=nlaylte
+        J2DD2=2
+        J2DD1=1
+        J2BOT=3*J2-2
+                                            do jl=1,kdlon
+        ZTAUDD(JL,J2DD1)= tautotal(jl,J2,iir)*0.5
+        ZTAUDD(JL,J2DD2)= tautotal(jl,J2,iir)*0.5
+        ZOMEGADD(JL,J2DD1)= omegtotal(jl,J2,iir)
+        ZOMEGADD(JL,J2DD2)= omegtotal(jl,J2,iir)
+        ZGDD(JL,J2DD1)= gtotal(jl,J2,iir)
+        ZGDD(JL,J2DD2)= gtotal(jl,J2,iir)
+                                            enddo
+C
+C     ------------------------------------------------------------------
+C
+C*         2.0.3   calcul de la diffusion
+C                  ----------------------
+C
+
+c-----------------------------------------------------------------------
+        CALL flusv(KDLON,0
+     &  ,NDD,ZOMEGADD,ZGDD,ZTAUDD,PEMIS
+     &  ,ZZBHDD,ZZBSDD
+     &  ,ZZFAHDD,ZZFDHDD)
+c!
+c!  Cumul des flux sur le spectre hors bande du CO2
+c!
+        DO indd=1,ndd+1
+           do jl=1,kdlon
+             ZFAHDD(jl,indd)=ZFAHDD(jl,indd)+ZZFAHDD(jl,indd)
+             ZFDHDD(jl,indd)=ZFDHDD(jl,indd)+ZZFDHDD(jl,indd)
+           enddo
+        ENDDO
+10001 CONTINUE
+
+      DO J2=1,nlaylte+1
+        J2DD=(nlaylte-J2+1)*2+1
+        do jl=1,kdlon
+          PFLUC(JL,1,J2)=PFLUC(JL,1,J2)+ZFAHDD(JL,J2DD)
+          PFLUC(JL,2,J2)=PFLUC(JL,2,J2)-ZFDHDD(JL,J2DD)
+        enddo
+      ENDDO
+
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwflux.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwflux.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwflux.F	(revision 57)
@@ -0,0 +1,514 @@
+       subroutine lwflux (ig0,kdlon,kflev,dp
+     .                   ,bsurf,btop,blev,blay,dbsublay
+     .                   ,tlay, tlev, dt0      ! pour sortie dans g2d uniquement
+     .                   ,emis
+     .                   , tautotal,omegtotal,gtotal
+     .                   ,coolrate,fluxground,fluxtop
+     .                   ,netrad)
+
+c----------------------------------------------------------------------
+c     LWFLUX     computes the fluxes
+c----------------------------------------------------------------------
+
+      implicit none
+ 
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+#include "comg1d.h"
+ 
+#include "yomlw.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer ig0                   ! 
+      integer kdlon                 ! part of ngrid
+      integer kflev                 ! part of nlayer
+
+      real dp (ndlo2,kflev)         ! layer pressure thickness (Pa)
+
+      real bsurf (ndlo2,nir)             ! surface spectral planck function
+      real blev (ndlo2,nir,kflev+1)      ! level   spectral planck function
+      real blay (ndlo2,nir,kflev)        ! layer   spectral planck function
+      real btop (ndlo2,nir)              ! top spectral planck function
+      real dbsublay (ndlo2,nir,2*kflev)  ! layer gradient spectral planck
+                                         ! function in sub layers
+
+      real dt0 (ndlo2)                 ! surface temperature discontinuity
+      real tlay (ndlo2,kflev)          ! layer temperature
+      real tlev (ndlo2,kflev+1)        ! level temperature
+
+      real emis (ndlo2)                  ! surface emissivity
+
+      real tautotal(ndlo2,kflev,nir)  ! \   Total single scattering
+      real omegtotal(ndlo2,kflev,nir) !  >  properties (Addition of the
+      real gtotal(ndlo2,kflev,nir)    ! /   NAERKIND aerosols prop.)
+
+
+c                                                            outputs:
+c                                                            --------
+      real coolrate(ndlo2,kflev)    ! radiative cooling rate (K/s) 
+      real netrad (ndlo2,kflev)     ! radiative budget (W/m2) 
+      real fluxground(ndlo2)        ! downward flux on the ground
+                                    ! for surface radiative budget
+      real fluxtop(ndlo2)           ! upward flux on the top of atm ("OLR")
+
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer ja,jl,j,i,ig1d,ig,l,ndim
+      parameter(ndim = ndlon*(nuco2+1)*(nflev+2)*(nflev+2))
+      real  ksidb (ndlon,nuco2+1,0:nflev+1,0:nflev+1) ! net exchange rate (W/m2)
+
+      real dpsgcp (0:nflev+1,0:nflev+1)    !  dp/(g.cp)
+      real temp (0:nflev+1,0:nflev+1)       
+
+      real fluxdiff(ndlon,2,nflev+1)  ! diffusion flux: upward(1) downward(2) 
+
+      real*4 reel4
+
+c     To compute IR flux in the atmosphere  (For diagnostic only !!)
+      logical computeflux
+      real coefd(ngridmx,nuco2,nflev+1,nflev+1) 
+      real coefu(ngridmx,nuco2,0:nflev,nflev+1)
+      real flw_up(ngridmx,nflev+1), flw_dn(ngridmx,nflev+1) ! fluxes (W/m2)
+
+
+      call zerophys(ndim, ksidb)
+
+c----------------------------------------------------------------------
+c         1.1   exchanges (layer i <--> all layers up to i) 
+c               -------------------------------------------
+
+      do i = 1,nlaylte
+        do j = i+1,nlaylte
+          do ja = 1,nuco2
+            do jl = 1,kdlon
+
+      ksidb(jl,ja,i,j) = xi(ig0+jl,ja,i,j) 
+     .                 * (blay(jl,ja,j)-blay(jl,ja,i))
+c                                                        ksidb reciprocity
+c                                                        -----------------
+      ksidb(jl,ja,j,i) = -ksidb(jl,ja,i,j)
+      
+            enddo
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         1.2   exchanges (ground <--> all layers) 
+c               ----------------------------------
+
+      do i = 1,nlaylte
+        do ja = 1,nuco2
+          do jl = 1,kdlon
+
+      ksidb(jl,ja,i,0) = xi(ig0+jl,ja,0,i) 
+     .                 * (bsurf(jl,ja)-blay(jl,ja,i))
+c                                                        ksidb reciprocity
+c                                                        -----------------
+      ksidb(jl,ja,0,i) = -ksidb(jl,ja,i,0)
+
+          enddo
+        enddo
+      enddo
+
+c--------------------------------------------------------
+c  Here we add the neighbour contribution 
+c           for exchanges between ground and first layer
+c--------------------------------------------------------
+
+        do ja = 1,nuco2
+          do jl = 1,kdlon
+
+      ksidb(jl,ja,1,0) = ksidb(jl,ja,1,0) 
+     .                 - xi_ground(ig0+jl,ja) 
+     .                 * (blev(jl,ja,1)-blay(jl,ja,1))
+
+cc                                                       ksidb reciprocity
+cc                                                       -----------------
+      ksidb(jl,ja,0,1) = - ksidb(jl,ja,1,0)
+
+          enddo
+        enddo
+
+c----------------------------------------------------------------------
+c         1.3   exchanges (layer i <--> space) 
+c               ------------------------------
+
+      do i = 1,nlaylte
+        do ja = 1,nuco2
+          do jl = 1,kdlon
+
+      ksidb(jl,ja,i,nlaylte+1) = xi(ig0+jl,ja,i,nlaylte+1) 
+     .                       * (-blay(jl,ja,i))
+c                                                        ksidb reciprocity
+c                                                        -----------------
+      ksidb(jl,ja,nlaylte+1,i) = - ksidb(jl,ja,i,nlaylte+1)
+
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         1.4   exchanges (ground <--> space) 
+c               -----------------------------
+
+      do ja = 1,nuco2
+        do jl = 1,kdlon
+
+      ksidb(jl,ja,0,nlaylte+1) = xi(ig0+jl,ja,0,nlaylte+1) 
+     .                       * (-bsurf(jl,ja))
+
+c                                                        ksidb reciprocity
+c                                                        -----------------
+      ksidb(jl,ja,nlaylte+1,0) = - ksidb(jl,ja,0,nlaylte+1)
+
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         2.0   sum of band 1 and 2 of co2 contribution 
+c               ---------------------------------------
+
+      do i = 0,nlaylte+1
+        do j = 0,nlaylte+1
+          do jl = 1,kdlon
+
+            ksidb(jl,3,i,j)= ksidb(jl,1,i,j) + ksidb(jl,2,i,j)
+
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         3.0   Diffusion
+c               ---------
+
+      i = nlaylte+1
+      do jl = 1,kdlon
+        fluxdiff(jl,1,i)   = 0.
+        fluxdiff(jl,2,i)   = 0.
+      enddo
+
+      call lwdiff (kdlon,kflev
+     .         ,bsurf,btop,dbsublay
+     .         ,tautotal,omegtotal,gtotal
+     .         ,emis,fluxdiff)
+
+c----------------------------------------------------------------------
+c         4.0   Radiative Budget for each layer i
+c               ---------------------------------
+
+      do i = 1,nlaylte
+        do jl = 1,kdlon
+            netrad(jl,i) = 0.
+        enddo
+      enddo
+
+      do i = 1,nlaylte
+        do j = 0,nlaylte+1
+          do jl = 1,kdlon
+
+            netrad(jl,i) = netrad(jl,i) + ksidb(jl,3,i,j)
+
+          enddo
+        enddo
+      enddo
+c                                                 diffusion contribution
+c                                                 ----------------------
+      do i = 1,nlaylte
+        do jl = 1,kdlon
+
+          netrad(jl,i) = netrad(jl,i) 
+     .                 - fluxdiff(jl,1,i+1) - fluxdiff(jl,2,i+1)   
+     .                 + fluxdiff(jl,1,i)   + fluxdiff(jl,2,i)
+
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         4.0   cooling rate for each layer i
+c               -----------------------------
+
+      do i = 1,nlaylte
+        do jl = 1,kdlon
+
+          coolrate(jl,i) = gcp * netrad(jl,i) / dp(jl,i)
+
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         5.0   downward flux (all layers --> ground): "fluxground" 
+c               ---------------------------------------------------
+
+      do jl = 1,kdlon
+          fluxground(jl) = 0.
+      enddo
+
+      do i = 1,nlaylte
+        do ja = 1,nuco2
+          do jl = 1,kdlon
+
+      fluxground(jl) = fluxground(jl)
+     .               + xi(ig0+jl,ja,0,i) * (blay(jl,ja,i))
+
+          enddo
+        enddo
+      enddo
+   
+      do jl = 1,kdlon
+        fluxground(jl) = fluxground(jl) - fluxdiff(jl,2,1)  
+      enddo
+
+c----------------------------------------------------------------------
+c         6.0   outgoing flux (all layers --> space): "fluxtop" 
+c               ---------------------------------------------------
+
+      do jl = 1,kdlon
+          fluxtop(jl) = 0.
+      enddo
+
+      do i = 0,nlaylte
+        do jl = 1,kdlon
+           fluxtop(jl) = fluxtop(jl)- ksidb(jl,3,i,nlaylte+1)
+        enddo
+      enddo
+   
+      do jl = 1,kdlon
+        fluxtop(jl) = fluxtop(jl) + fluxdiff(jl,1,nlaylte+1)  
+      enddo
+
+c----------------------------------------------------------------------
+c         6.5 ONLY FOR DIAGNOSTIC : Compute IR flux in the atmosphere 
+c             -------------------
+c     The broadband fluxes (W.m-2) at every level  from surface level (l=1) 
+c     up the top of the  upper layer (here: l=nlaylte+1) are:
+c     upward : flw_up(ig,l)   ;   downward : flw_dn(ig,j) 
+c
+      computeflux = .false.
+
+      IF (computeflux) THEN  ! not used by the GCM only for diagnostic !
+c      upward flux 
+c      ~~~~~~~~~~~
+       do i = 0,nlaylte
+        do j = 1,nlaylte+1
+         do ja = 1,nuco2
+          do jl = 1,kdlon
+            coefu(jl,ja,i,j) =0.
+            do l=j,nlaylte+1 
+              coefu(jl,ja,i,j)=coefu(jl,ja,i,j)+xi(ig0+jl,ja,l,i)
+            end do
+
+          enddo
+         enddo
+        enddo
+       enddo
+       do j = 1,nlaylte+1
+        do jl = 1,kdlon
+           flw_up(jl,j) = 0.
+           do ja = 1,nuco2
+             flw_up(jl,j)=flw_up(jl,j)+bsurf(jl,ja)*coefu(jl,ja,0,j)
+             do i=1,j-1
+              flw_up(jl,j)=flw_up(jl,j)+blay(jl,ja,i)*coefu(jl,ja,i,j) 
+             end do 
+           end do
+           flw_up(jl,j)=flw_up(jl,j) + fluxdiff(jl,1,j)
+        end do
+       end do
+
+c      downward flux
+c      ~~~~~~~~~~~~~
+       do i = 1,nlaylte+1
+        do j = 1,nlaylte+1
+         do ja = 1,nuco2
+          do jl = 1,kdlon
+            coefd(jl,ja,i,j) =0.
+            do l=0,j-1
+              coefd(jl,ja,i,j)=coefd(jl,ja,i,j)+xi(ig0+jl,ja,l,i)
+            end do
+          enddo
+         enddo
+        enddo
+       enddo
+       do j = 1,nlaylte+1
+        do jl = 1,kdlon
+           flw_dn(jl,j) = 0.
+           do ja = 1,nuco2
+             do i=j,nlaylte
+              flw_dn(jl,j)=flw_dn(jl,j)+blay(jl,ja,i)*coefd(jl,ja,i,j) 
+             end do 
+           end do
+           flw_dn(jl,j)=flw_dn(jl,j) - fluxdiff(jl,2,j)
+        end do
+       end do
+      END IF
+
+c----------------------------------------------------------------------
+c         7.0   outputs Grads 2D
+c               ----------------
+
+c ig1d: point de la grille physique ou on veut faire la sortie
+c ig0+1:  point du decoupage de la grille physique
+c ig:   point pour les variables decoupees
+
+c#ifdef undim
+      if (callg2d) then
+
+      ig1d = ngridmx/2 + 1
+c     ig1d = ngridmx
+
+      if ((ig0+1).LE.ig1d .and. ig1d.LE.(ig0+kdlon)
+     .    .OR.  ngridmx.EQ.1   ) then
+
+          ig = ig1d-ig0
+        print*, 'Sortie g2d: ig1d, ig, ig0', ig1d, ig, ig0
+
+c--------------------------------------------
+c   Ouverture de g2d.dat
+c--------------------------------------------
+      if (g2d_premier) then
+        open (47,file='g2d.dat'
+clmd     &       ,form='unformatted',access='direct',recl=4)
+     &        ,form='unformatted',access='direct',recl=1
+     &        ,status='unknown')
+        g2d_irec=0
+        g2d_appel=0
+        g2d_premier=.false.
+      endif
+        g2d_appel = g2d_appel+1
+
+c--------------------------------------------
+c   Sortie g2d des xi proches + distants 
+c--------------------------------------------
+cl                               if (nflev .NE. 500) then
+      do ja = 1,nuco2
+        do j = 0,nlaylte+1
+          do i = 0,nlaylte+1
+            g2d_irec=g2d_irec+1
+            reel4 = xi(ig1d,ja,i,j)
+            write(47,rec=g2d_irec) reel4
+          enddo
+        enddo
+      enddo
+cl                               endif
+
+c------------------------------------------------------
+c   Writeg2d des ksidb 
+c------------------------------------------------------
+      do ja = 1,nuco2
+c       ja=1
+        do j = 0,nlaylte+1
+          do i = 0,nlaylte+1
+            g2d_irec=g2d_irec+1
+            reel4 = ksidb(ig,ja,i,j)
+            write(47,rec=g2d_irec) reel4
+          enddo
+        enddo
+      enddo
+
+      do j = 0,nlaylte+1
+        do i = 0,nlaylte+1
+          g2d_irec=g2d_irec+1
+          reel4 = ksidb(ig,3,i,j)
+          write(47,rec=g2d_irec) reel4
+        enddo
+      enddo
+
+c------------------------------------------------------
+c  Writeg2d dpsgcp
+c------------------------------------------------------
+
+        do j = 1 , nlaylte
+          do i = 0 , nlaylte+1
+            dpsgcp(i,j) = dp(ig,j) / gcp
+          enddo
+        enddo
+
+        do i = 0 , nlaylte+1
+c         dpsgcp(i,0) = 0.0002  ! (rapport ~ entre 1000 et 10000 pour le sol)
+          dpsgcp(i,0) = 1.      ! (pour regler l'echelle des sorties)
+          dpsgcp(i,nlaylte+1) = 0.
+        enddo
+
+c     print*
+c     print*,'gcp: ',gcp
+c     print*
+c       do i = 0 , nlaylte+1
+c     print*,i,'dp: ',dp(ig,i)
+c       enddo
+c     print*
+c       do i = 0 , nlaylte+1
+c     print*,i,'dpsgcp: ',dpsgcp(i,1)
+c       enddo
+  
+      do j = 0,nlaylte+1
+        do i = 0,nlaylte+1
+          g2d_irec=g2d_irec+1
+          reel4 = dpsgcp(i,j)
+          write(47,rec=g2d_irec) reel4
+        enddo
+      enddo
+
+c------------------------------------------------------
+c  Writeg2d temperature
+c------------------------------------------------------
+
+        do j = 1 , nlaylte
+          do i = 0 , nlaylte+1
+            temp(i,j) = tlay(ig,j)
+          enddo
+        enddo
+
+        do i = 0 , nlaylte+1
+          temp(i,0) = tlev(ig,1)+dt0(ig)     ! temperature surface
+          temp(i,nlaylte+1) = 0.               ! temperature espace  (=0)
+        enddo
+
+      do j = 0,nlaylte+1
+        do i = 0,nlaylte+1
+          g2d_irec=g2d_irec+1
+          reel4 = temp(i,j)
+          write(47,rec=g2d_irec) reel4
+        enddo
+      enddo
+
+        write(76,*) 'ig1d, ig, ig0', ig1d, ig, ig0
+        write(76,*) 'nlaylte', nlaylte
+        write(76,*) 'nflev', nflev
+        write(76,*) 'kdlon', kdlon
+        write(76,*) 'ndlo2', ndlo2
+        write(76,*) 'ndlon', ndlon
+      do ja=1,4
+        write(76,*) 'bsurf', ja, bsurf(ig,ja)
+        write(76,*) 'btop', ja, btop(ig,ja)
+
+        do j=1,nlaylte+1
+          write(76,*) 'blev', ja, j, blev(ig,ja,j)
+        enddo
+
+        do j=1,nlaylte
+          write(76,*) 'blay', ja, j, blay(ig,ja,j)
+        enddo
+
+        do j=1,2*nlaylte
+          write(76,*) 'dbsublay', ja, j, dbsublay(ig,ja,j)
+        enddo
+      enddo
+
+      endif
+c************************************************************************
+c#endif 
+      endif  !   callg2d
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwi.F	(revision 57)
@@ -0,0 +1,223 @@
+      subroutine lwi (ig0,kdlon,kflev
+     .                ,psi,zdblay,pdp
+     .                ,newpcolc )
+
+
+      implicit none
+
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "comg1d.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "yomlw.h"
+ 
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C                             -   lwi    -    
+C
+C     PURPOSE:       Shema semi - implicite 
+C
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+
+c************************************************************************
+c
+c        0.    Declarations
+c              ------------
+c
+c-------------------------------------------------------------------------
+c        0.1   Arguments
+c              ---------
+c
+ 
+      integer ig0, kdlon,kflev
+
+      real    psi(ndlo2,kflev)
+     .     ,  zdblay(ndlo2,nir,kflev)
+     .     ,  pdp(ndlo2,kflev)
+
+
+      real    newpcolc(ndlo2,kflev)
+
+c-------------------------------------------------------------------------
+c        0.2   local arrays
+c              ------------
+c
+      real    di(ndlon,nflev) 
+     .      , hi(ndlon,nflev) 
+     .      , bi(ndlon,nflev) 
+
+      real    ci(ndlon,nflev) 
+     .      , ai(ndlon,nflev) 
+      real    deltat
+
+      real   semit, denom
+
+      integer i, jl
+
+c************************************************************************
+c
+c        1.    Initialisations
+c              ---------------
+c
+c-----------------------------------------------------------------------
+ 
+        deltat = dtphys * iradia
+c       print*,'SEMI = ',semi, '(expl:0  semi-implicite:0.5  impl:1)'
+        semit = semi * deltat
+c       semi = 0.
+
+c       print*,'dtphys,iradia,deltat,semit:',dtphys,iradia,deltat,semit
+c       print*,'g,cpp',g,cpp
+
+
+c************************************************************************
+c
+c        2.    
+c              ---------------
+c
+c-------------------------------------------------------------------------
+c        2.1   Calcul des di
+c              -------------
+c
+
+
+      do i = 1 , nlaylte-1
+        do jl = 1 , kdlon
+c     -------------------
+      di(jl,i) =  1 + semit * (g / pdp(jl,i) / cpp) * (
+     .    ( xi(ig0+jl,1,i,nlaylte+1) 
+     .    + xi(ig0+jl,1,i,i+1) 
+     .    + xi(ig0+jl,1,i,i-1) )
+     .    *    zdblay(jl,1,i) 
+     .  + ( xi(ig0+jl,2,i,nlaylte+1) 
+     .    + xi(ig0+jl,2,i,i+1) 
+     .    + xi(ig0+jl,2,i,i-1) )
+     .    *    zdblay(jl,2,i) 
+     .     )
+c     -------------------
+        enddo
+      enddo
+
+
+
+c couche nlaylte
+c ------------
+c      , on enleve i,i+1 sinon on a 2 fois le cooling2space
+
+      do jl = 1 , kdlon
+c     -------------------
+      di(jl,nlaylte) =  1 + semit * (g / pdp(jl,nlaylte) / cpp) * (
+     .    ( xi(ig0+jl,1,nlaylte,nlaylte+1) 
+     .    + xi(ig0+jl,1,nlaylte,nlaylte-1) )
+     .    *    zdblay(jl,1,nlaylte) 
+     .  + ( xi(ig0+jl,2,nlaylte,nlaylte+1) 
+     .    + xi(ig0+jl,2,nlaylte,nlaylte-1) )
+     .    *    zdblay(jl,2,nlaylte) 
+     .     )
+c     -------------------
+      enddo
+
+
+c-------------------------------------------------------------------------
+c        2.2   Calcul des hi
+c              -------------
+c
+
+      do i = 1 , nlaylte-1
+        do jl = 1 , kdlon
+c     -------------------
+      hi(jl,i) =    - semit * (g / pdp(jl,i) / cpp) *
+     .            (    xi(ig0+jl,1,i,i+1) * zdblay(jl,1,i+1)
+     .               + xi(ig0+jl,2,i,i+1) * zdblay(jl,2,i+1)   )
+c     -------------------
+        enddo
+      enddo
+
+c-------------------------------------------------------------------------
+c        2.3   Calcul des bi
+c              -------------
+c
+
+
+      do i = 2 , nlaylte
+        do jl = 1 , kdlon
+c     -------------------
+      bi(jl,i) =   - semit * (g / pdp(jl,i) / cpp) * 
+     .           (     xi(ig0+jl,1,i,i-1) * zdblay(jl,1,i-1)
+     .               + xi(ig0+jl,2,i,i-1) * zdblay(jl,2,i-1)   )
+c     -------------------
+        enddo
+      enddo
+
+
+c couche 1
+c --------
+c  tant qu'on a pas un calcul propre de zdblay(0) qui tienne compte de 
+c    la discontinuite de temperature au sol , on met  b1 = 0
+
+
+      do jl = 1 , kdlon
+        bi(jl,1) = 0 
+      enddo
+
+c-------------------------------------------------------------------------
+c        2.4   
+c              -------------
+c
+
+c couche nlaylte
+c ------------
+
+      do jl = 1 , kdlon
+c     -------------------
+      ci(jl,nlaylte) = (gcp * psi(jl,nlaylte) / pdp(jl,nlaylte))
+     .                   / di(jl,nlaylte)
+
+      ai(jl,nlaylte) = - bi(jl,nlaylte) / di(jl,nlaylte)
+c     -------------------
+      enddo
+
+
+
+      do i = nlaylte-1 , 1 , -1
+        do jl = 1 , kdlon
+c     -------------------
+      denom = di(jl,i) + hi(jl,i) * ai(jl,i+1)
+
+      ci(jl,i) = (  gcp * psi(jl,i) / pdp(jl,i)
+     .             - hi(jl,i) * ci(jl,i+1)  )  / denom
+ 
+      ai(jl,i) = -bi(jl,i) / denom
+c     -------------------
+        enddo
+      enddo
+
+
+c-------------------------------------------------------------------------
+c        2.5   
+c              -------------
+c
+
+c couche 1
+c -------
+      do jl = 1 , kdlon
+        newpcolc(jl,1) = ci(jl,1)
+      enddo
+
+
+      do i = 2 , nlaylte
+        do jl = 1 , kdlon
+           newpcolc(jl,i) = ci(jl,i) + ai(jl,i) * newpcolc(jl,i-1)
+        enddo
+      enddo
+
+
+
+c-------------------------------------------------------------------------
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwmain.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwmain.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwmain.F	(revision 57)
@@ -0,0 +1,200 @@
+       subroutine lwmain (ig0,icount,kdlon,kflev
+     .                   ,dp,dt0,emis
+     .                   ,plev,tlev,tlay,aerosol,coolrate
+     .                   ,fluxground,fluxtop
+     .                   ,netrad)
+
+c----------------------------------------------------------------------
+c     LWMAIN     organizes the LTE longwave calculations
+c     for layer 1 to layer "nlaylte" (stored in  "yomlw.h")
+c----------------------------------------------------------------------
+
+      implicit none
+ 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+#include "comg1d.h"
+ 
+#include "yomlw.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer ig0
+      integer icount
+      integer kdlon            ! part of ngrid
+      integer kflev            ! part of nlayer
+
+      real dp (ndlo2,kflev)         ! layer pressure thickness (Pa)
+      real dt0 (ndlo2)              ! surface temperature discontinuity (K)
+      real emis (ndlo2)             ! surface emissivity
+      real plev (ndlo2,kflev+1)     ! level pressure (Pa)
+      real tlev (ndlo2,kflev+1)     ! level temperature (K)
+      real tlay (ndlo2,kflev)       ! layer temperature (K)
+      real aerosol(ndlo2,kflev,naerkind)      !  aerosol extinction optical
+c                         depth at reference wavelength "longrefvis" set
+c                         in dimradmars.h , in each layer, for one of
+c                         the "naerkind" kind of aerosol optical properties.
+
+
+c                                                            outputs:
+c                                                            --------
+      real coolrate(ndlo2,kflev)      ! cooling rate (K/s)
+      real fluxground(ndlo2)          ! downward ground flux (W/m2)
+      real fluxtop(ndlo2)             ! outgoing upward flux (W/m2) ("OLR")
+      real netrad (ndlo2,kflev)       ! radiative budget (W/m2) 
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      real aer_t (ndlon,nuco2,nflev+1)  ! transmission (aer)
+      real co2_u (ndlon,nuco2,nflev+1)  ! absorber amounts (co2)
+      real co2_up (ndlon,nuco2,nflev+1) ! idem scaled by the pressure (co2)
+
+      real bsurf (ndlon,nir)            ! surface spectral planck function
+      real btop (ndlon,nir)             ! top spectral planck function
+      real blev (ndlon,nir,nflev+1)     ! level   spectral planck function
+      real blay (ndlon,nir,nflev)       ! layer   spectral planck function
+      real dblay (ndlon,nir,nflev)      ! layer gradient spectral planck function
+      real dbsublay (ndlon,nir,2*nflev) ! layer gradient spectral planck function
+                                        ! in sub layers
+
+      real tautotal(ndlon,nflev,nir)  ! \   Total single scattering
+      real omegtotal(ndlon,nflev,nir) !  >  properties (Addition of the
+      real gtotal(ndlon,nflev,nir)    ! /   NAERKIND aerosols prop.)
+
+      real newcoolrate(ndlon,nflev) ! cooling rate (K/s) / with implicite scheme
+
+      integer jk,jkk,ja,jl
+
+      logical firstcall
+      save firstcall
+      data firstcall/.true./
+
+
+c----------------------------------------------------------------------
+c         0.3   Initialisation
+c               --------------
+
+      if (firstcall) then
+
+        firstcall = .false.
+
+        do jkk = 0 , nlaylte+1
+          do jk = 0 , nlaylte+1
+            do ja = 1 , nuco2
+              do jl = 1 , ngridmx
+                  xi (jl,ja,jk,jkk)=0.
+              enddo
+            enddo
+          enddo
+        enddo
+
+      endif
+
+c----------------------------------------------------------------------
+c         1.0   planck function
+c               ---------------
+
+      call lwb ( kdlon, kflev, tlev, tlay, dt0
+     .         , bsurf, btop, blay, blev, dblay, dbsublay)
+
+c----------------------------------------------------------------------
+c         2.0   absorber amounts
+c               ----------------
+
+      call lwu ( kdlon, kflev
+     .         , dp, plev, tlay, aerosol  
+     .         , aer_t, co2_u, co2_up
+     .         ,tautotal,omegtotal,gtotal)   
+
+c----------------------------------------------------------------------
+c         3.0   transmission functions / exchange coefficiants
+c               ----------------------------------------------
+
+c                                                                distants
+c                                                                --------
+                    if( mod(icount-1,ilwd).eq.0) then
+
+c     print*, 'CALL of DISTANTS'
+      call lwxd ( ig0, kdlon, kflev, emis
+     .          , aer_t, co2_u, co2_up)
+
+                    endif
+c                                                              neighbours
+c                                                              ----------
+                    if( mod(icount-1,ilwn).eq.0) then
+
+c     print*, 'CALL of NEIGHBOURS'
+      call lwxn ( ig0, kdlon, kflev
+     .          , dp
+     .          , aer_t, co2_u, co2_up)
+
+                    endif
+c                                                              boundaries
+c                                                              ----------
+                    if( mod(icount-1,ilwb).eq.0) then
+
+c     print*, 'CALL of BOUNDARIES'
+      call lwxb ( ig0, kdlon, kflev, emis
+     .          , aer_t, co2_u, co2_up)
+
+                    endif
+
+c----------------------------------------------------------------------
+c         4.0   cooling rate
+c               ------------
+
+      call lwflux ( ig0, kdlon, kflev, dp
+     .            , bsurf, btop, blev, blay, dbsublay
+     .            , tlay, tlev, dt0      ! pour sortie dans g2d uniquement
+     .            , emis
+     .            , tautotal,omegtotal,gtotal
+     .            , coolrate, fluxground, fluxtop
+     .            , netrad)
+
+c     do jk = 1, nlaylte
+c       print*,coolrate(1,jk)
+c     enddo
+      
+c       do jkk = 0 , nlaylte+1
+c         do jk = 0 , nlaylte+1
+c           do ja = 1 , nuco2
+c             do jl = 1 , ngridmx
+c      if (xi (jl,ja,jk,jkk) .LT. 0
+c    .       .OR. xi (jl,ja,jk,jkk) .GT. 1 ) then
+c                 print*,'xi bande',ja,jk,jkk,xi (jl,ja,jk,jkk)
+c      endif
+c             enddo
+c           enddo
+c         enddo
+c       enddo
+
+c----------------------------------------------------------------------
+c
+c          5.    shema semi-implicite  (lwi) 
+c                ---------------------------
+c
+c
+      call lwi (ig0,kdlon,kflev,netrad,dblay,dp
+     .          , newcoolrate)
+c
+c  Verif que   (X sol,space) + somme(X i,sol) = 1
+c
+      do jkk = 1 , nlaylte
+        do jl = 1 , kdlon
+c     print*,'NEW et OLD coolrate :',jkk,newcoolrate(jl,jkk) 
+c    .  ,coolrate(jl,jkk)
+      coolrate(jl,jkk) = newcoolrate(jl,jkk)
+        enddo
+      enddo
+c
+c----------------------------------------------------------------------
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwtt.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwtt.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwtt.F	(revision 57)
@@ -0,0 +1,65 @@
+      subroutine lwtt (kdlon,u,up,nu,tr)
+
+c----------------------------------------------------------------------
+c     LWTT   computes the longwave transmission functions
+c            for all the absorbers in all spectral intervals
+c            using pade approximants and horner's algorithm
+c----------------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "yomlw.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer kdlon            ! part of ngrid
+      integer nu               ! 
+
+      real    u (ndlo2,nu)     ! absorber amounts 
+      real    up (ndlo2,nu)    ! idem scaled by the pressure
+
+c                                                            outputs:
+c                                                            --------
+      real    tr (ndlo2,nu)    ! transmission functions
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer ja,jl
+
+      real xn (ndlon)
+      real xd (ndlon)
+      real ueq (ndlon)
+
+c----------------------------------------------------------------------
+c   Transmission by the CO2 15 microns band:
+c   ----------------------------------------
+
+      do  ja=1,nu
+	    do jl=1,kdlon
+c                              equivalent absorber amount (Doppler effect)
+c                             --------------------------------------------
+	      ueq(jl) = sqrt(up(jl,ja))
+     .              +cst_voigt(1,ja)*u(jl,ja)**cst_voigt(2,ja)
+
+c                                                      Horner's algorithm
+c                                                      ------------------
+            xn(jl) = ga(1,ja) + 
+     .      ueq(jl)*(ga(2,ja) + ueq(jl) * ga(3,ja) )
+            xd(jl) = gb(1,ja) + ueq(jl)*(gb(2,ja) + 
+     .      ueq(jl) * ( gb(3,ja) + ueq(jl)  ))
+            tr(jl,ja) = xn(jl) / xd(jl)
+
+	    enddo
+      enddo
+
+c----------------------------------------------------------------------
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwu.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwu.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwu.F	(revision 57)
@@ -0,0 +1,242 @@
+      subroutine lwu (kdlon,kflev
+     &                ,dp,plev,tlay,aerosol 
+     &                ,aer_t,co2_u,co2_up
+     &                ,tautotal,omegtotal,gtotal)
+
+c----------------------------------------------------------------------
+c     LWU   computes  - co2: longwave effective absorber amounts including 
+c                      pressure and temperature effects 
+c                     - aerosols: amounts for every band
+c                                transmission for bandes 1 and 2 of co2
+c----------------------------------------------------------------------
+
+c-----------------------------------------------------------------------
+c ATTENTION AUX UNITES:
+c le facteur 10*g fait passer des kg m-2 aux g cm-2
+c-----------------------------------------------------------------------
+c! modif diffusion
+c! on ne change rien a la bande CO2 : les quantites d'absorbant CO2
+c! sont multipliees par 1.66
+c! pview= 1/cos(teta0)=1.66
+c-----------------------------------------------------------------------
+ 
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "comcstfi.h"
+
+#include "yomaer.h"
+#include "yomlw.h"
+
+#include "fisice.h"
+#include "callkeys.h"
+
+#include "aerice.h"
+ 
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------                                    
+c                                                            inputs:
+c                                                            -------
+      integer kdlon        ! part of ngrid
+      integer kflev        ! part of nalyer
+
+      real dp (ndlo2,kflev)         ! layer pressure thickness (Pa)
+      real plev (ndlo2,kflev+1)     ! level pressure (Pa)
+      real tlay (ndlo2,kflev)       ! layer temperature (K)
+      real aerosol (ndlo2,kflev,naerkind) ! aerosol extinction optical depth
+c                         at reference wavelength "longrefvis" set
+c                         in dimradmars.h , in each layer, for one of
+c                         the "naerkind" kind of aerosol optical properties.
+
+
+c                                                            outputs:
+c                                                            --------
+      real aer_t (ndlo2,nuco2,kflev+1)   ! transmission (aer) 
+      real co2_u (ndlo2,nuco2,kflev+1)   ! absorber amounts (co2)
+      real co2_up (ndlo2,nuco2,kflev+1)  ! idem scaled by the pressure (co2)
+
+      real tautotal(ndlo2,kflev,nir)  ! \   Total single scattering
+      real omegtotal(ndlo2,kflev,nir) !  >  properties (Addition of the
+      real gtotal(ndlo2,kflev,nir)    ! /   NAERKIND aerosols properties)
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer jl,jk,jkl,ja,n
+ 
+      real aer_u (ndlon,nir,nflev+1)     ! absorber amounts (aer) extinction
+      real co2c           ! co2 concentration (pa/pa)
+      real pview          ! cosecant of viewing angle
+      real pref           ! reference pressure (1013 mb = 101325 Pa)
+      real tx,tx2
+      real phi (ndlon,nuco2)
+      real psi (ndlon,nuco2)
+      real plev2 (ndlon,nflev+1)
+      real zzz
+
+      real ray,coefsize,coefsizew,coefsizeg 
+
+c************************************************************************
+c----------------------------------------------------------------------
+c         0.3  Initialisation  
+c               -------------
+
+      pview = 1.66
+      co2c = 0.95           
+      pref = 101325.
+
+      do jk=1,nlaylte+1
+        do jl=1,kdlon
+          plev2(jl,jk)=plev(jl,jk)*plev(jl,jk)
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c  Computing TOTAL single scattering parameters by adding properties of
+c  all the NAERKIND kind of aerosols in each IR band
+
+      call zerophys(ndlon*kflev*nir,tautotal)
+      call zerophys(ndlon*kflev*nir,omegtotal)
+      call zerophys(ndlon*kflev*nir,gtotal)
+
+      do n=1,naerkind
+        do ja=1,nir
+          do jk=1,nlaylte
+            do jl = 1,kdlon
+c TEST : to account for the varying sol/ir optical depth of ice with varying crystal size     
+c      : and for varying w,g with varying crystal size     
+              if (activice.and.n.eq.naerkind) then 
+        ray=min( max(rice(jl,jk)*1.e+6, 1.),10.) 
+            if (ja.eq.1.or.ja.eq.2) then 
+          coefsize=(-0.00382*ray**3.+0.0503*ray**2.+0.03531)
+     &             /QIRsQREF(ja,n)
+          coefsizew=(-0.011*ray**2.+0.1824*ray-0.1283)
+     &           /omegaIR(ja,n)
+          coefsizeg=(-0.00122*ray**3.+0.009161*ray**2.+  
+     &          0.1182*ray-0.096877)/gIR(ja,n)
+                elseif (ja.eq.3) then
+          coefsize=(-0.00324*ray**3.+0.0419*ray**2.+0.0459)
+     &             /QIRsQREF(ja,n)
+          coefsizew=(-0.01292*ray**2.+0.1963*ray-0.06566)
+     &           /omegaIR(ja,n)
+          coefsizeg=(0.00271*ray**3.-0.05959*ray**2.+
+     &          0.4411*ray-0.2724)/gIR(ja,n)
+                elseif (ja.eq.4) then
+          coefsize=(-0.0003823*ray**3.+0.0104*ray**2.+0.005966)
+     &             /QIRsQREF(ja,n)
+              coefsizew=(-0.002*ray**3.+0.02623*ray**2.-0.014465)
+     &           /omegaIR(ja,n)
+          coefsizeg=(-0.0017192*ray**3.+0.0259*ray**2.-
+     &          0.027692*ray+0.016099)/gIR(ja,n)
+            endif
+        if (coefsize.le.0.or.coefsizew.le.0.or.coefsizeg.le.0) 
+     &        stop'pb dans lwu avec prp opt glace'
+
+            tautotal(jl,jk,ja)=tautotal(jl,jk,ja) +
+     &          QIRsQREF(ja,n)*aerosol(jl,jk,n)
+     &          *coefsize
+                omegtotal(jl,jk,ja) =  omegtotal(jl,jk,ja) + 
+     &           QIRsQREF(ja,n)*aerosol(jl,jk,n)*omegaIR(ja,n)
+     &          *coefsize*coefsizew
+                gtotal(jl,jk,ja) =  gtotal(jl,jk,ja) + 
+     &           QIRsQREF(ja,n)*aerosol(jl,jk,n)*omegaIR(ja,n)*gIR(ja,n)
+     &          *coefsize*coefsizew*coefsizeg     
+              else
+              tautotal(jl,jk,ja)=tautotal(jl,jk,ja) +
+     &           QIRsQREF(ja,n)*aerosol(jl,jk,n)
+              omegtotal(jl,jk,ja) =  omegtotal(jl,jk,ja) + 
+     &           QIRsQREF(ja,n)*aerosol(jl,jk,n)*omegaIR(ja,n)
+              gtotal(jl,jk,ja) =  gtotal(jl,jk,ja) + 
+     &           QIRsQREF(ja,n)*aerosol(jl,jk,n)*omegaIR(ja,n)*gIR(ja,n)
+              endif
+            enddo
+          enddo
+        enddo
+      enddo
+      do ja=1,nir
+        do jk=1,nlaylte
+          do jl = 1,kdlon
+             gtotal(jl,jk,ja)=gtotal(jl,jk,ja)/omegtotal(jl,jk,ja)
+             omegtotal(jl,jk,ja)=omegtotal(jl,jk,ja)/tautotal(jl,jk,ja)
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         1.0   cumulative (aerosol) amounts (for every band)
+c               ----------------------------
+
+      jk=nlaylte+1
+      do ja=1,nir
+        do jl = 1 , kdlon
+          aer_u(jl,ja,jk)=0.
+        enddo
+      enddo
+
+      do jk=1,nlaylte
+        jkl=nlaylte+1-jk
+        do ja=1,nir
+          do jl=1,kdlon
+             aer_u(jl,ja,jkl)=aer_u(jl,ja,jkl+1)+ tautotal(jl,jkl,ja)
+          enddo
+        enddo
+      enddo                 
+
+c----------------------------------------------------------------------
+c         1.0   bands 1 and 2 of co2
+c               --------------------
+
+      jk=nlaylte+1
+      do ja=1,nuco2
+        do jl = 1 , kdlon
+          co2_u(jl,ja,jk)=0.
+          co2_up(jl,ja,jk)=0.
+          aer_t(jl,ja,jk)=1.
+        enddo
+      enddo
+
+      do jk=1,nlaylte
+                       jkl=nlaylte+1-jk
+        do ja=1,nuco2
+          do jl=1,kdlon
+
+c                 introduces temperature effects on absorber(co2) amounts
+c                 -------------------------------------------------------
+            tx = sign(min(abs(tlay(jl,jkl)-tref),70.)
+     .         ,tlay(jl,jkl)-tref)
+            tx2=tx*tx
+            phi(jl,ja)=at(1,ja)*tx+bt(1,ja)*tx2
+            psi(jl,ja)=at(2,ja)*tx+bt(2,ja)*tx2
+            phi(jl,ja)=exp(phi(jl,ja)/cst_voigt(2,ja))
+            psi(jl,ja)=exp(2.*psi(jl,ja))
+
+c                                        cumulative absorber(co2) amounts
+c                                        --------------------------------
+            co2_u(jl,ja,jkl)=co2_u(jl,ja,jkl+1)
+     .     +         pview/(10*g)*phi(jl,ja)*dp(jl,jkl)*co2c
+
+            co2_up(jl,ja,jkl)=co2_up(jl,ja,jkl+1)
+     .     +         pview/(10*g*2*pref)*psi(jl,ja)
+     .     *        (plev2(jl,jkl)-plev2(jl,jkl+1))*co2c
+
+
+c                                                  (aerosol) transmission
+c                                                  ----------------------
+c   on calcule directement les transmissions pour les aerosols.
+c   on multiplie le Qext  par 1-omega dans la bande du CO2.
+c   et pourquoi pas d'abord?  hourdin@lmd.ens.fr
+
+           zzz=pview*(1.-omegtotal(jl,jkl,ja))
+           aer_t(jl,ja,jkl)=exp(-zzz*aer_u(jl,ja,jkl))
+          
+          enddo
+        enddo
+      enddo                 
+
+c----------------------------------------------------------------------
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxb.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxb.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxb.F	(revision 57)
@@ -0,0 +1,220 @@
+      subroutine lwxb (ig0,kdlon,kflev
+     .                ,emis
+     .                ,aer_t,co2_u,co2_up)
+
+c----------------------------------------------------------------------
+c     LWXB   computes transmission function and exchange coefficients
+c                          for boundaries 
+c                          (co2 / aerosols)
+c                       (bands 1 and 2 of co2) 
+c----------------------------------------------------------------------
+c 
+c              |---|---|---|---|---|---|---|---|
+c   kflev+1    |***|***|***|***|***|***|***| 0 |  (space)
+c              |---|---|---|---|---|---|---|---|
+c    kflev     |***|   |   |   |   |   | 0 |***|
+c              |---|---|---|---|---|---|---|---|
+c     ...      |***|   |   |   |   | 0 |   |***|
+c              |---|---|---|---|---|---|---|---|
+c      4       |***|   |   |   | 0 |   |   |***|
+c              |---|---|---|---|---|---|---|---|
+c      3       |***|   |   | 0 |   |   |   |***|
+c              |---|---|---|---|---|---|---|---|
+c      2       |***|   | 0 |   |   |   |   |***|
+c              |---|---|---|---|---|---|---|---|
+c      1       |***| 0 |   |   |   |   |   |***|
+c              |---|---|---|---|---|---|---|---|
+c      0       | 0 |***|***|***|***|***|***|***|  (ground)
+c              |---|---|---|---|---|---|---|---|
+c                0   1   2   3   4  ...  k |k+1
+c             (ground)                    (space)
+c
+c  (*)  xi computed in this subroutine
+c----------------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+ 
+#include "yomlw.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer kdlon          ! part of ngrid
+      integer kflev          ! part of nalyer
+
+      real emis (ndlo2)                  ! surface emissivity
+      real aer_t (ndlo2,nuco2,kflev+1)   ! transmission (aer)
+      real co2_u (ndlo2,nuco2,kflev+1)   ! absorber amounts (co2)
+      real co2_up (ndlo2,nuco2,kflev+1)  ! idem scaled by the pressure (co2)
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer ja,jl,jk,ig0
+
+      real zt_co2 (ndlon,nuco2)
+      real zt_aer (ndlon,nuco2)
+      real zu (ndlon,nuco2)
+      real zup (ndlon,nuco2)
+c                                          2 for ground(1) and space(2)
+      real trans (ndlon,nuco2,2,0:nflev+1)
+      real ksi (ndlon,nuco2,2,0:nflev+1)
+c                                                       only for space
+      real trans_emis (ndlon,nuco2,0:nflev+1)
+      real ksi_emis (ndlon,nuco2,0:nflev+1)
+
+c*************************************************************************
+c         1.0   Transmissions 
+c               -------------
+c----------------------------------------------------------------------
+c         1.1   Direct Transmission 
+c               -------------------
+
+c                                                                 space
+c                                                                 -----
+      do jk = 1 , nlaylte+1
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+            zu(jl,ja)  = co2_u(jl,ja,jk)
+            zup(jl,ja) = co2_up(jl,ja,jk)
+            zt_aer(jl,ja) = aer_t(jl,ja,jk)
+          enddo
+        enddo
+
+        call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,2,jk)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+
+      enddo
+c                                                                 ground
+c                                                                 -----
+      do jk = 1 , nlaylte+1
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+            zu(jl,ja) =  co2_u(jl,ja,1)  - co2_u(jl,ja,jk)
+            zup(jl,ja) = co2_up(jl,ja,1) - co2_up(jl,ja,jk)
+            zt_aer(jl,ja) = aer_t(jl,ja,1) /aer_t(jl,ja,jk)
+          enddo
+        enddo
+
+        call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,1,jk)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+
+      enddo
+
+c----------------------------------------------------------------------
+c         1.2   Transmission with reflexion
+c               ---------------------------
+
+c                                                                 space
+c                                                                 -----
+      do jk = 1 , nlaylte+1
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+
+            zu(jl,ja) =   2 * co2_u(jl,ja,1)  - co2_u(jl,ja,jk)
+            zup(jl,ja) =  2 * co2_up(jl,ja,1) - co2_up(jl,ja,jk)
+            zt_aer(jl,ja) = aer_t(jl,ja,1) 
+     .                    * aer_t(jl,ja,1)
+     .                    / aer_t(jl,ja,jk)
+
+          enddo
+        enddo
+
+        call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+            trans_emis(jl,ja,jk)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+
+      enddo
+
+c*************************************************************************
+c         2.0   Exchange Coefficiants
+c               ---------------------
+
+      do jk = 1 , nlaylte
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+
+c-------------------------------------------------------------------------
+c        2.1    colling to space  (from layer 1,nlaylte toward "layer" nlaylte+1)
+c               ----------------
+
+
+      ksi(jl,ja,2,jk) = trans(jl,ja,2,jk+1)
+     .                - trans(jl,ja,2,jk)
+
+      ksi_emis(jl,ja,jk) = trans_emis(jl,ja,jk)
+     .                   - trans_emis(jl,ja,jk+1) 
+
+      xi(ig0+jl,ja,jk,nlaylte+1)= ksi(jl,ja,2,jk) 
+     .                        + ksi_emis(jl,ja,jk)* (1 - emis(jl))
+
+c                                                         ksi Reciprocity
+c                                                         ---------------
+      xi(ig0+jl,ja,nlaylte+1,jk)      = xi(ig0+jl,ja,jk,nlaylte+1)
+
+c-------------------------------------------------------------------------
+c        2.2    echange with ground  (from "layer" 0 toward layers 1,nlaylte)
+c               -------------------
+
+
+      ksi(jl,ja,1,jk) = trans(jl,ja,1,jk) 
+     .                - trans(jl,ja,1,jk+1)
+
+      xi(ig0+jl,ja,0,jk) = ksi(jl,ja,1,jk) * emis(jl)
+
+c                                                         ksi Reciprocity
+c                                                         ---------------
+      xi(ig0+jl,ja,jk,0) = xi(ig0+jl,ja,0,jk)
+
+c-------------------------------------------------------------------------
+          enddo
+        enddo
+      enddo
+
+c-------------------------------------------------------------------------
+c       2.3     echange ground-space  (from "layer" 0 toward "layer" nlaylte+1)
+c               ----------------------
+
+c Is not used because we use sigma T4 for the ground budget in physiq.F
+
+      do ja = 1 , nuco2
+        do jl = 1 , kdlon
+
+      ksi(jl,ja,1,nlaylte+1) = trans(jl,ja,1,nlaylte+1) 
+      xi(ig0+jl,ja,0,nlaylte+1) = ksi(jl,ja,1,nlaylte+1) * emis(jl)
+
+c                                                         ksi Reciprocity
+c                                                         ---------------
+      xi(ig0+jl,ja,nlaylte+1,0) = xi(ig0+jl,ja,0,nlaylte+1)
+
+        enddo
+      enddo
+
+c-------------------------------------------------------------------------
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxd.F	(revision 57)
@@ -0,0 +1,257 @@
+      subroutine lwxd (ig0,kdlon,kflev,emis
+     .                ,aer_t,co2_u,co2_up)
+
+c----------------------------------------------------------------------
+c     LWXD   computes transmission function and exchange coefficiants
+c                        for distant layers
+c                          (co2 / aerosols)
+c                       (bands 1 and 2 of co2) 
+c----------------------------------------------------------------------
+c  
+c              |---|---|---|---|---|---|---|---|
+c   kflev+1    |   |   |   |   |   |   |   | 0 |  (space)
+c              |---|---|---|---|---|---|---|---|
+c    kflev     |   |***|***|***|***|   | 0 |   |
+c              |---|---|---|---|---|---|---|---|
+c     ...      |   |***|***|***|   | 0 |   |   |
+c              |---|---|---|---|---|---|---|---|
+c      4       |   |***|***|   | 0 |   |***|   | 
+c              |---|---|---|---|---|---|---|---|
+c      3       |   |***|   | 0 |   |***|***|   |
+c              |---|---|---|---|---|---|---|---|
+c      2       |   |   | 0 |   |   |***|***|   |
+c              |---|---|---|---|---|---|---|---|
+c      1       |   | 0 |   |   |***|***|***|   |
+c              |---|---|---|---|---|---|---|---|
+c      0       | 0 |   |   |***|***|***|***|   |  (ground)
+c              |---|---|---|---|---|---|---|---|
+c                0   1   2   3   4  ...  k |k+1 
+c             (ground)                    (space)
+c  
+c  (*)  xi computed in this subroutine
+c----------------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+ 
+#include "yomlw.h"
+#include "callkeys.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer ig0
+      integer kdlon      ! part of ngrid
+      integer kflev      ! part of nalyer
+ 
+      real emis (ndlo2)                  ! surface emissivity
+      real aer_t (ndlo2,nuco2,kflev+1)   ! transmission (aer)
+      real co2_u (ndlo2,nuco2,kflev+1)   ! absorber amounts (co2)
+      real co2_up (ndlo2,nuco2,kflev+1)  ! idem scaled by the pressure (co2)
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer ja,jl,jk,jkk,ndim
+      parameter(ndim = ndlon*nuco2*(nflev+2)*(nflev+2))
+
+
+      real zu (ndlon,nuco2)
+      real zup (ndlon,nuco2)
+      real zt_co2 (ndlon,nuco2)
+      real zt_aer (ndlon,nuco2)
+
+      real ksi (ndlon,nuco2,0:nflev+1,0:nflev+1)
+      real ksi_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
+      real trans (ndlon,nuco2,0:nflev+1,0:nflev+1)
+      real trans_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
+
+c----------------------------------------------------------------------
+      call zerophys(ndim,ksi_emis)
+c----------------------------------------------------------------------
+c         1.0   Transmission functions
+c               ----------------------
+
+c----------------------------------------------------------------------
+c        1.1   Direct transmission 
+c              -------------------
+
+      do jk = 1 , nlaylte+1
+        do jkk = jk , nlaylte+1
+
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+c                                                                   co2
+c                                                                   ---
+              zu(jl,ja) =  co2_u(jl,ja,jk)  - co2_u(jl,ja,jkk)
+              zup(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jkk)
+c                                                                   aer
+c                                                                   ---
+              zt_aer(jl,ja)= aer_t(jl,ja,jk)
+     .                      /aer_t(jl,ja,jkk)
+
+            enddo
+          enddo
+
+          call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+c                                                            co2 and aer
+c                                                            -----------
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+              trans(jl,ja,jk,jkk) = zt_co2(jl,ja) * zt_aer(jl,ja)
+            enddo
+          enddo
+c                                                       trans reciprocity
+c                                                       -----------------
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+              trans(jl,ja,jkk,jk) = trans(jl,ja,jk,jkk) 
+c           if (trans(jl,ja,jk,jkk) .LT. 0 ) then
+c           print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
+c           endif
+c           if (trans(jl,ja,jk,jkk) .GT. 1) then
+c           print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
+c           trans(jl,ja,jk,jkk)=1
+c           print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
+c           endif
+
+            enddo
+          enddo
+     
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         1.2   Transmission with reflexion
+c               ---------------------------
+
+      do jk = 1 , nlaylte+1
+        do jkk = jk , nlaylte+1
+
+      if (callemis) then
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+c                                                                   co2
+c                                                                   ---
+              zu(jl,ja)  = 2 * co2_u(jl,ja,1)  - co2_u(jl,ja,jk)
+     .                                         - co2_u(jl,ja,jkk)
+              zup(jl,ja) = 2 * co2_up(jl,ja,1) - co2_up(jl,ja,jk)
+     .                                         - co2_up(jl,ja,jkk)
+c                                                                   aer
+c                                                                   ---
+                zt_aer(jl,ja)  = aer_t(jl,ja,1)
+     .                         * aer_t(jl,ja,1)
+     .                         / aer_t(jl,ja,jk)
+     .                         / aer_t(jl,ja,jkk)
+            enddo
+          enddo
+
+          call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+c                                                            co2 and aer
+c                                                            -----------
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+              trans_emis(jl,ja,jk,jkk) = zt_co2(jl,ja)
+     .                                 * zt_aer(jl,ja)
+            enddo
+          enddo
+
+      else
+
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+              trans_emis(jl,ja,jk,jkk) = 1.
+            enddo
+          enddo
+
+      endif
+c                                                       trans reciprocity
+c                                                       -----------------
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+              trans_emis(jl,ja,jkk,jk) = trans_emis(jl,ja,jk,jkk)
+c         if (trans_emis(jl,ja,jk,jkk) .LT. 0 
+c    .                .OR.  trans_emis(jl,ja,jk,jkk) .GT. 1) then
+c     print*,'trans_emis bande',ja,jk,jkk,trans_emis(jl,ja,jk,jkk)
+c         endif
+            enddo
+          enddo
+
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         2.0   Exchange Coefficiants
+c               ---------------------
+
+      do jk = 1 , nlaylte-2
+        do jkk = jk+2 , nlaylte
+          do ja = 1 , nuco2
+            do jl = 1 , kdlon
+
+      ksi(jl,ja,jk,jkk) = 
+     .            trans(jl,ja,jk+1,jkk)   - trans(jl,ja,jk,jkk)
+     .          - trans(jl,ja,jk+1,jkk+1) + trans(jl,ja,jk,jkk+1)
+
+      ksi_emis(jl,ja,jk,jkk) = 
+     .   trans_emis(jl,ja,jk,jkk)   - trans_emis(jl,ja,jk+1,jkk)
+     . - trans_emis(jl,ja,jk,jkk+1) + trans_emis(jl,ja,jk+1,jkk+1)
+
+c       if (ksi(jl,ja,jk,jkk) .LT. 0 ) then
+c           print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
+c           ksi(jl,ja,jk,jkk)=0
+c           print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
+c       endif
+c       if (ksi(jl,ja,jk,jkk) .GT. 1) then
+c           print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
+c           ksi(jl,ja,jk,jkk)=1
+c           print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
+c       endif
+
+c       if (ksi_emis(jl,ja,jk,jkk) .LT. 0 
+c    .                .OR.  ksi_emis(jl,ja,jk,jkk) .GT. 1) then
+c     print*,'ksi_emis bande',ja,jk,jkk,ksi_emis(jl,ja,jk,jkk)
+c       endif
+
+      xi(ig0+jl,ja,jk,jkk) = ksi(jl,ja,jk,jkk)
+     .      + ksi_emis(jl,ja,jk,jkk) * (1 - emis(jl))
+
+c                                                        ksi reciprocity
+c                                                        ---------------
+      ksi(jl,ja,jkk,jk)      = ksi(jl,ja,jk,jkk)
+      ksi_emis(jl,ja,jkk,jk) = ksi_emis(jl,ja,jk,jkk)
+      xi(ig0+jl,ja,jkk,jk)   = xi(ig0+jl,ja,jk,jkk)
+
+            enddo
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+c         2.1   Save xi_emis for neighbours (lwxn.F)
+c               -----------------------------------
+
+      do jk = 1 , nlaylte-1
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+
+c     ksi_emis(jl,ja,jk,jk+1) = 
+c    .   trans_emis(jl,ja,jk,jk+1)   - trans_emis(jl,ja,jk+1,jk+1)
+c    . - trans_emis(jl,ja,jk,jk+2) + trans_emis(jl,ja,jk+1,jk+2)
+
+      xi_emis(ig0+jl,ja,jk) =
+     .                 ksi_emis(jl,ja,jk,jk+1) * (1-emis(jl))
+
+          enddo
+        enddo
+      enddo
+
+c----------------------------------------------------------------------
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxn.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxn.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/lwxn.F	(revision 57)
@@ -0,0 +1,389 @@
+      subroutine lwxn ( ig0,kdlon,kflev
+     .                , dp
+     .                , aer_t,co2_u,co2_up)
+
+c----------------------------------------------------------------------
+c     LWXN   computes transmission function and exchange coefficiants
+c                        for neighbours layers
+c                          (co2 / aerosols)
+c                       (bands 1 and 2 of co2) 
+c----------------------------------------------------------------------
+c  
+c              |---|---|---|---|---|---|---|---|
+c   kflev+1    |   |   |   |   |   |   |   | 0 |  (space)
+c              |---|---|---|---|---|---|---|---|
+c    kflev     |   |   |   |   |   |***| 0 |   |
+c              |---|---|---|---|---|---|---|---|
+c     ...      |   |   |   |   |***| 0 |***|   |
+c              |---|---|---|---|---|---|---|---|
+c      4       |   |   |   |***| 0 |***|   |   | 
+c              |---|---|---|---|---|---|---|---|
+c      3       |   |   |***| 0 |***|   |   |   |
+c              |---|---|---|---|---|---|---|---|
+c      2       |   |***| 0 |***|   |   |   |   |
+c              |---|---|---|---|---|---|---|---|
+c      1       |   | 0 |***|   |   |   |   |   |
+c              |---|---|---|---|---|---|---|---|
+c      0       | 0 |   |   |   |   |   |   |   |  (ground)
+c              |---|---|---|---|---|---|---|---|
+c                0   1   2   3   4  ...  k |k+1 
+c             (ground)                    (space)
+c  
+c  (*)  xi computed in this subroutine
+c----------------------------------------------------------------------
+c                                                                       
+c  *********************************************************** nj=1
+c
+c
+c                                       sublayer    1                  
+c
+c
+c                                ----------------------------- nj=2
+c
+c                                       sublayer    2                  
+c
+c    - - - -  LAYER j - - - - -  ----------------------------- nj=3
+c
+c                                       sublayer    3                  
+c                                ----------------------------- nj=4
+c                                       sublayer  ncouche                  
+c  *********************************************************** ni=nj=ncouche+1
+c                                       sublayer  ncouche                  
+c                                ----------------------------- ni=4
+c                                       sublayer    3                  
+c
+c    - - - -  LAYER i - - - - -  ----------------------------- ni=3
+c
+c                                       sublayer    2                  
+c                     
+c                                ----------------------------- ni=2
+c
+c
+c                                       sublayer    1                  
+c
+c
+c  *********************************************************** ni=1
+c                                                                       
+c-----------------------------------------------------------------------
+c ATTENTION AUX UNITES:
+c le facteur 10*g fait passer des kg m-2 aux g cm-2
+c-----------------------------------------------------------------------
+
+      implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+ 
+#include "yomlw.h"
+#include "callkeys.h"
+
+c----------------------------------------------------------------------
+c         0.1   arguments
+c               ---------
+c                                                            inputs:
+c                                                            -------
+      integer ig0
+      integer kdlon     ! part of ngrid
+      integer kflev     ! part of nalyer
+
+      real dp (ndlo2,kflev)              ! layer pressure thickness (Pa)
+
+      real aer_t (ndlo2,nuco2,kflev+1)   ! transmission (aer)
+      real co2_u (ndlo2,nuco2,kflev+1)   ! absorber amounts (co2)
+      real co2_up (ndlo2,nuco2,kflev+1)  ! idem scaled by the pressure (co2)
+
+c----------------------------------------------------------------------
+c         0.2   local arrays
+c               ------------
+
+      integer ja,jl,jk,nlmd,ni,nj
+
+      integer nmax
+      parameter (nmax=50)               ! max: 50 sublayers
+
+      real cn (nmax), cb (nmax)
+
+      real zu_layer_i (ndlon,nuco2)
+      real zup_layer_i (ndlon,nuco2)
+      real zt_aer_layer_i (ndlon,nuco2)
+
+      real zu_layer_j (ndlon,nuco2)
+      real zup_layer_j (ndlon,nuco2)
+      real zt_aer_layer_j (ndlon,nuco2)
+
+      real zu (ndlon,nuco2)
+      real zup (ndlon,nuco2)
+      real zt_co2 (ndlon,nuco2)
+      real zt_aer (ndlon,nuco2)
+
+      real zu_i (ndlon,nuco2,nmax+1)
+      real zup_i (ndlon,nuco2,nmax+1)
+      real zu_j (ndlon,nuco2,nmax+1)
+      real zup_j (ndlon,nuco2,nmax+1)
+      real zt_aer_i (ndlon,nuco2,nmax+1)
+      real zt_aer_j (ndlon,nuco2,nmax+1)
+
+      real trans (ndlon,nuco2,nmax+1,nmax+1)
+      real ksi (ndlon,nuco2,nflev-1)
+
+c----------------------------------------------------------------------
+c         0.3   Initialisation
+c               --------------
+
+      jk=ncouche+1
+      do ja = 1 ,nuco2
+        do jl = 1 , kdlon
+          zu_i (jl,ja,jk) = 0.
+          zup_i (jl,ja,jk) = 0.
+          zu_j (jl,ja,jk) = 0.
+          zup_j (jl,ja,jk) = 0.
+          zt_aer_i (jl,ja,jk) = 1.
+          zt_aer_j (jl,ja,jk) = 1.
+        enddo
+      enddo
+
+      if (linear) then
+
+      do nlmd = 1 ,ncouche
+        cn(nlmd)=(1.0/ncouche)
+        cb(nlmd)=(ncouche-nlmd+0.5)/ncouche
+c       print*,nlmd,cb(nlmd),cn(nlmd)
+      enddo
+
+      else
+
+      do nlmd = 1 ,ncouche-1
+        cn(nlmd)=(1-alphan)*alphan**(nlmd-1)
+        cb(nlmd)=0.5*(1+alphan)*alphan**(nlmd-1)
+      enddo
+      cn(ncouche)=alphan**(ncouche-1)
+      cb(ncouche)=0.5*alphan**(ncouche-1)
+
+      endif
+
+c test
+      if (nmax .LT. ncouche) then
+        print*,'!!!!! ATTENTION !!!!! '
+        print*,'probleme dans lwxn.F'
+        print*,' nmax=',nmax,'  < ncouche=',ncouche
+        call exit(1)
+      endif
+
+c----------------------------------------------------------------------
+      do jk = 1 , nlaylte-1
+c----------------------------------------------------------------------
+c         1.0   (co2) amount and (aer) transmission for all sublayers  
+c               ----------------------------------------------------
+
+        do ja = 1 , nuco2
+          do jl = 1 , kdlon
+
+c                                                        layer i (down)
+c                                                        -------------
+      zu_layer_i(jl,ja) =  co2_u(jl,ja,jk)  - co2_u(jl,ja,jk+1)
+      zup_layer_i(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jk+1)
+      zt_aer_layer_i(jl,ja) = aer_t(jl,ja,jk)
+     .                       / aer_t(jl,ja,jk+1)
+                                  
+      do nlmd=1,ncouche
+        zu_i(jl,ja,nlmd)=cn(nlmd)*zu_layer_i(jl,ja)
+        zup_i(jl,ja,nlmd)=cn(nlmd)*zup_layer_i(jl,ja)
+        zt_aer_i(jl,ja,nlmd)=zt_aer_layer_i(jl,ja)**cn(nlmd)
+      enddo
+
+c                                                          layer j (up)
+c                                                          ------------
+      zu_layer_j(jl,ja) =  co2_u(jl,ja,jk+1)  - co2_u(jl,ja,jk+2)
+      zup_layer_j(jl,ja) = co2_up(jl,ja,jk+1) - co2_up(jl,ja,jk+2)
+      zt_aer_layer_j(jl,ja) = aer_t(jl,ja,jk+1)
+     .                       / aer_t(jl,ja,jk+2)
+        
+      do nlmd=1,ncouche
+        zu_j(jl,ja,nlmd)=cn(nlmd)*zu_layer_j(jl,ja)
+        zup_j(jl,ja,nlmd)=cn(nlmd)*zup_layer_j(jl,ja)
+        zt_aer_j(jl,ja,nlmd)=zt_aer_layer_j(jl,ja)**cn(nlmd)
+      enddo
+
+          enddo
+        enddo
+
+c----------------------------------------------------------------------
+c         2.0   transmissions between all sublayers
+c               ------------------------------------
+
+        do ni = 1 ,ncouche+1
+
+            do ja = 1 ,nuco2
+              do jl = 1 , kdlon
+      zu(jl,ja)=0.    
+      zup(jl,ja)=0.    
+      zt_aer(jl,ja)=1.    
+                        
+      do nlmd=ni,ncouche+1
+        zu(jl,ja)=zu(jl,ja)+zu_i(jl,ja,nlmd)    
+        zup(jl,ja)=zup(jl,ja)+zup_i(jl,ja,nlmd)    
+        zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_i(jl,ja,nlmd)    
+      enddo
+              enddo
+            enddo
+
+      call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+                         
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,ni,ncouche+1)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+                   
+c on ajoute la couche J
+            do ja = 1 ,nuco2
+              do jl = 1 , kdlon
+      zu(jl,ja)=zu(jl,ja)+zu_layer_j(jl,ja) 
+      zup(jl,ja)=zup(jl,ja)+zup_layer_j(jl,ja) 
+      zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_j(jl,ja) 
+              enddo
+            enddo
+                     
+      call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+                         
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,ni,1)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+                   
+        enddo
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+        
+        do nj = 1 ,ncouche+1
+
+            do ja = 1 ,nuco2
+              do jl = 1 , kdlon
+      zu(jl,ja)=0.    
+      zup(jl,ja)=0.    
+      zt_aer(jl,ja)=1.    
+                        
+      do nlmd=nj,ncouche+1
+        zu(jl,ja)=zu(jl,ja)+zu_j(jl,ja,nlmd)    
+        zup(jl,ja)=zup(jl,ja)+zup_j(jl,ja,nlmd)    
+        zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_j(jl,ja,nlmd)    
+      enddo
+              enddo
+            enddo
+                     
+      call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+                         
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,ncouche+1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+
+c on ajoute la couche I
+            do ja = 1 ,nuco2
+              do jl = 1 , kdlon
+      zu(jl,ja)=zu(jl,ja)+zu_layer_i(jl,ja) 
+      zup(jl,ja)=zup(jl,ja)+zup_layer_i(jl,ja) 
+      zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_i(jl,ja) 
+              enddo
+            enddo
+                     
+      call lwtt(kdlon,zu,zup,nuco2,zt_co2)
+                         
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            trans(jl,ja,1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
+          enddo
+        enddo
+                   
+        enddo
+        
+c----------------------------------------------------------------------
+c         3.0   global exchange coefficiant between neigthbours
+c               -----------------------------------------------
+        
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            ksi(jl,ja,jk) = 0.
+          enddo
+        enddo
+
+        do ni = 1 ,ncouche
+          do ja = 1 ,nuco2
+            do jl = 1 , kdlon
+
+      ksi(jl,ja,jk)=ksi(jl,ja,jk) +
+     .             ( trans(jl,ja,ni+1,ncouche+1)
+     .             - trans(jl,ja,ni,ncouche+1)
+     .             - trans(jl,ja,ni+1,1)
+     .             + trans(jl,ja,ni,1) )
+     .             * (cb(ni)*dp(jl,jk)) * 2    
+     .             /  (dp(jl,jk) + dp(jl,jk+1))       !!!!!!!!!!!!!!!!!!!
+
+            enddo
+          enddo
+        enddo
+
+        do nj = 1 ,ncouche
+          do ja = 1 ,nuco2
+            do jl = 1 , kdlon
+
+      ksi(jl,ja,jk)=ksi(jl,ja,jk) +
+     .             ( trans(jl,ja,ncouche+1,nj+1)
+     .             - trans(jl,ja,1,nj+1)
+     .             - trans(jl,ja,ncouche+1,nj)
+     .             + trans(jl,ja,1,nj) )
+     .             * (cb(nj)*dp(jl,jk+1)) * 2 
+     .             /  (dp(jl,jk) + dp(jl,jk+1))       !!!!!!!!!!!!!!!!!!!
+
+            enddo
+          enddo
+        enddo
+
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            xi(ig0+jl,ja,jk,jk+1) = ksi(jl,ja,jk)
+     .                            + xi_emis(ig0+jl,ja,jk)
+
+c                                                        ksi reciprocity
+c                                                        ---------------
+            xi(ig0+jl,ja,jk+1,jk) = xi(ig0+jl,ja,jk,jk+1)
+          enddo
+        enddo
+
+c----------------------------------------------------------------------
+c         4.0   Special treatment for ground
+c               ----------------------------
+
+
+      if (jk .EQ. 1) then
+
+        do ja = 1 ,nuco2
+          do jl = 1 , kdlon
+            xi_ground(ig0+jl,ja)=0.
+          enddo
+        enddo
+
+        do ni = 1 ,ncouche
+          do ja = 1 ,nuco2
+              do jl = 1 , kdlon
+
+      xi_ground(ig0+jl,ja) = xi_ground(ig0+jl,ja)
+     .                     + ( trans(jl,ja,ni+1,ncouche+1)
+     .                        -trans(jl,ja,ni,ncouche+1))
+     .                     * 2 * cb(ni)
+            enddo
+          enddo
+        enddo
+
+      endif
+
+c----------------------------------------------------------------------
+      enddo    !  boucle sur jk
+c----------------------------------------------------------------------
+      return
+      end
+
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mkstat.F90
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mkstat.F90	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mkstat.F90	(revision 57)
@@ -0,0 +1,164 @@
+subroutine mkstats(ierr)
+
+ 
+!
+!  This program writes a stats.nc file from sums and sums of squares
+!  to means and standard deviations and also writes netcdf style
+!  file so that the data can be viewed easily.  The data file is
+!  overwritten in place.  
+!  SRL  21 May 1996
+!  Yann W. july 2003
+
+
+implicit none
+
+#include "dimensions.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+integer :: ierr,nid,nbvar,i,ndims,lt,nvarid
+integer, dimension(4) :: id,varid,start,size
+integer, dimension(5) :: dimids
+character (len=50) :: name,nameout,units,title
+real, dimension(iip1,jjp1,llm) :: sum3d,square3d,mean3d,sd3d
+real, dimension(iip1,jjp1) :: sum2d,square2d,mean2d,sd2d
+real, dimension(istime) :: time
+real, dimension(jjp1) :: lat
+real, dimension(iip1) :: lon
+real, dimension(llm) :: alt
+logical :: lcopy=.true.
+!integer :: latid,lonid,altid,timeid
+integer :: meanid,sdid
+!integer, dimension(4) :: dimout
+
+! Incrementation of count for the last step, which is not done in wstats
+count(istime)=count(istime)+1
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+! We catch the id of dimensions of the stats file
+
+ierr= NF_INQ_DIMID(nid,"latitude",id(1))
+ierr= NF_INQ_DIMID(nid,"longitude",id(2))
+ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+ierr= NF_INQ_VARID(nid,"latitude",varid(1))
+ierr= NF_INQ_VARID(nid,"longitude",varid(2))
+ierr= NF_INQ_VARID(nid,"altitude",varid(3))
+ierr= NF_INQ_VARID(nid,"Time",varid(4))
+
+! Time initialisation
+
+do i=1,istime
+   time(i)=i*24./istime
+#ifdef NC_DOUBLE
+   ierr= NF_PUT_VARA_DOUBLE(nid,varid(4),i,1,time(i))
+#else
+   ierr= NF_PUT_VARA_REAL(nid,varid(4),i,1,time(i))
+#endif
+enddo
+
+! We catche the values of the variables
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(1),lat)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(2),lon)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(3),alt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,varid(1),lat)
+         ierr = NF_GET_VAR_REAL(nid,varid(2),lon)
+         ierr = NF_GET_VAR_REAL(nid,varid(3),alt)
+#endif
+
+! We catch the number of variables in the stats file
+ierr = NF_INQ_NVARS(nid,nbvar)
+
+! to catche the "real" number of variables (without the "additionnal variables")
+nbvar=(nbvar-4)/2 
+
+do i=1,nbvar
+   varid=(i-1)*2+5
+
+   ! What's the variable's name?
+   ierr=NF_INQ_VARNAME(nid,varid,name)
+   write(*,*) "OK variable ",name
+   ! Its units?
+   units=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"units",units)
+   ! Its title?
+   title=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"title",title)
+   ! Its number of dimensions?   
+   ierr=NF_INQ_VARNDIMS(nid,varid,ndims)
+   ! Its values?
+
+   if(ndims==4) then ! lat, lon, alt & time
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=altid
+!      dimout(4)=timeid
+
+      size=(/iip1,jjp1,llm,1/)
+      do lt=1,istime
+         start=(/1,1,1,lt/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square3d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square3d)
+#endif
+         ! Calculation of these variables
+         mean3d=sum3d/count(lt)
+         sd3d=sqrt(max(0.,square3d/count(lt)-mean3d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd3d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd3d)
+#endif
+      enddo
+
+    else if (ndims.eq.3) then
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=timeid
+
+      size=(/iip1,jjp1,1,0/)
+      do lt=1,istime
+         start=(/1,1,lt,0/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square2d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square2d)
+#endif
+         ! Calculation of these variables
+         mean2d=sum2d/count(lt)
+         sd2d=sqrt(max(0.,square2d/count(lt)-mean2d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd2d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd2d)
+#endif
+      enddo
+
+    endif 
+enddo
+
+ierr= NF_CLOSE(nid)
+
+end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mucorr.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mucorr.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mucorr.F	(revision 57)
@@ -0,0 +1,102 @@
+      SUBROUTINE mucorr(npts,pdeclin, plat, pmu, pfract,phaut,prad)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul of equivalent solar angle and and fraction of day whithout 
+c   diurnal cycle.
+c
+c   parmeters :
+c   -----------
+c
+c      Input :
+c      -------
+c         npts             number of points
+c         pdeclin          solar declinaison
+c         plat(npts)        latitude
+c         phaut            hauteur typique de l'atmosphere
+c         prad             rayon planetaire
+c
+c      Output :
+c      --------
+c         pmu(npts)          equivalent cosinus of the solar angle
+c         pfract(npts)       fractionnal day
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c
+c    0. Declarations :
+c    -----------------
+
+c     Arguments :
+c     -----------
+      INTEGER npts
+      REAL plat(npts),pmu(npts), pfract(npts)
+      REAL phaut,prad,pdeclin
+c
+c     Local variables :
+c     -----------------
+      INTEGER j
+      REAL pi
+      REAL z,cz,sz,tz,phi,cphi,sphi,tphi
+      REAL ap,a,t,b, tp
+      REAL alph
+
+c-----------------------------------------------------------------------
+
+      pi = 4. * atan(1.0)
+      z = pdeclin
+      cz = cos (z)
+      sz = sin (z)
+
+      DO 20 j = 1, npts
+
+         phi = plat(j)
+         cphi = cos(phi)
+         if (cphi.le.1.e-9) cphi=1.e-9
+         sphi = sin(phi)
+         tphi = sphi / cphi
+         b = cphi * cz
+         t = -tphi * sz / cz
+         a = 1.0 - t*t
+         ap = a
+   
+         IF(t.eq.0.) then
+            tp=0.5*pi
+         ELSE
+            IF (a.lt.0.) a = 0.
+            t = sqrt(a) / t
+            IF (t.lt.0.) then
+               tp = -atan (-t) + pi
+            ELSE
+               tp = atan(t)
+            ENDIF
+         ENDIF
+         t = tp
+   
+         pmu(j) = (sphi*sz*t) / pi + b*sin(t)/pi
+         pfract(j) = t / pi
+         IF (ap .lt.0.) then
+            pmu(j) = sphi * sz
+            pfract(j) = 1.0
+         ENDIF
+         IF (pmu(j).le.0.0) pmu(j) = 0.0
+         pmu(j) = pmu(j) / pfract(j)
+         IF (pmu(j).eq.0.) pfract(j) = 0.
+
+   20 CONTINUE
+
+c-----------------------------------------------------------------------
+c   correction de rotondite:
+c   ------------------------
+
+      alph=phaut/prad
+      DO 30 j=1,npts
+c !!!!!!
+         pmu(j)=sqrt(1224.*pmu(j)*pmu(j)+1.)/35.
+c    $          (sqrt(alph*alph*pmu(j)*pmu(j)+2.*alph+1.)-alph*pmu(j))
+30    CONTINUE
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mufract.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mufract.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/mufract.F	(revision 57)
@@ -0,0 +1,92 @@
+      SUBROUTINE mufract(jjm,pdecli, plat, pmu, pfract)
+      IMPLICIT NONE
+c
+c=======================================================================
+c
+c   Calcul of equivalent solar angle and and fraction of day whithout 
+c   diurnal cycle.
+c
+c   parmeters :
+c   -----------
+c
+c      Input :
+c      -------
+c         jjm              number of points
+c         pdecli           solar declinaison
+c         plat(jjm)        latitude
+c
+c      Output :
+c      --------
+c         pmu(jjm)          equivalent cosinus of the solar angle
+c         pfract(jjm)       fractionnal day
+c
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c
+c    0. Declarations :
+c    -----------------
+c
+c     Arguments :
+c     -----------
+
+      INTEGER jjm
+      REAL plat(jjm),pmu(jjm), pfract(jjm)
+      REAL pdecli
+c
+c     Local variables :
+c     -----------------
+
+      INTEGER j
+      REAL pi
+      REAL z,cz,sz,tz,phi,cphi,sphi,tphi
+      REAL ap,a,t,b
+c
+c=======================================================================
+c
+      pi = 4. * atan(1.0)
+      z = pdecli
+      cz = cos (z*pi/180.)
+      sz = sin (z*pi/180.)
+c
+      DO 20 j = 1, jjm
+c
+         phi = plat(j)
+         cphi = cos(phi)
+         if (cphi.le.1.e-9) cphi=1.e-9
+         sphi = sin(phi)
+         tphi = sphi / cphi
+         b = cphi * cz
+         t = -tphi * sz / cz
+         a = 1.0 - t*t
+         ap = a
+         IF(t.eq.0.) THEN
+            t=0.5*pi
+         ELSE
+            IF (a.lt.0.) a = 0.
+            t = sqrt(a) / t
+            IF (t.lt.0.) THEN
+               t = -atan (-t) + pi
+            ELSE
+               t = atan(t)
+            ENDIF
+         ENDIF
+         pmu(j) = (sphi*sz*t) / pi + b*sin(t)/pi
+         pfract(j) = t / pi
+         IF (ap .lt.0.) THEN
+            pmu(j) = sphi * sz
+            pfract(j) = 1.0
+         ENDIF
+         IF (pmu(j).le.0.0) pmu(j) = 0.0
+         pmu(j) = pmu(j) / pfract(j)
+         IF (pmu(j).eq.0.) pfract(j) = 0.
+c
+   20 CONTINUE
+c
+      RETURN
+      END
+c
+c* end of mufract
+c=======================================================================
+c
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/multipl.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/multipl.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/multipl.F	(revision 57)
@@ -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: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newcondens.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newcondens.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newcondens.F	(revision 57)
@@ -0,0 +1,789 @@
+      SUBROUTINE newcondens(ngrid,nlayer,nq,ptimestep,
+     $                  pcapcal,pplay,pplev,ptsrf,pt,
+     $                  pphi,pdt,pdu,pdv,pdtsrf,pu,pv,pq,pdq,
+     $                  piceco2,psolaralb,pemisurf,
+     $                  pdtc,pdtsrfc,pdpsrf,pduc,pdvc,pdqc,
+     $                  fluxsurf_sw)
+                                                   
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Condensation/sublimation of CO2 ice on the ground and in the
+c   atmosphere 
+c   (Scheme described in Forget et al., Icarus, 1998)
+c
+c   author:   Francois Forget     1994-1996
+c   ------
+c
+c   input:
+c   ----- 
+c    ngrid                 nombre de points de verticales
+c                          (toutes les boucles de la physique sont au
+c                          moins vectorisees sur ngrid)
+c    nlayer                nombre de couches
+c    pplay(ngrid,nlayer)   Pressure levels 
+c    pplev(ngrid,nlayer+1) Pressure levels 
+c    pt(ngrid,nlayer)      temperature (en K)
+c    ptsrf(ngrid)          temperature de surface
+c 
+c                    \
+c    pdt(ngrid,nlayermx)   \  derivee temporelle physique avant condensation
+c                     /  ou sublimation pour  pt,ptsrf
+c    pdtsrf(ngrid)   /
+c
+c   output:
+c   -------
+c
+c    pdpsrf(ngrid)   \  derivee temporelle physique (contribution de
+c    pdtc(ngrid,nlayermx) /  la condensation ou sublimation) pour Ps,pt,ptsrf
+c    pdtsrfc(ngrid) /
+c
+c   Entree/sortie
+c   -------------
+c    
+c    piceco2(ngrid) :      quantite de glace co2 au sol (kg/m2)
+c    psolaralb(ngrid,2) :  albedo au sol
+c    pemisurf(ngrid)     :  emissivite du sol             
+
+c
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "surfdat.h"
+#include "comgeomfi.h"
+#include "comvert.h"
+#include "paramet.h"
+#include "callkeys.h"
+#include "tracer.h"
+
+#include "fisice.h"
+
+c-----------------------------------------------------------------------
+c    Arguments :
+c    ---------
+      INTEGER ngrid, nlayer, nq
+
+      REAL ptimestep 
+      REAL pplay(ngrid,nlayer),pplev(ngrid,nlayer+1)
+      REAL pcapcal(ngrid)
+      REAL pt(ngrid,nlayer)
+      REAL ptsrf(ngrid)
+      REAL pphi(ngrid,nlayer)
+      REAL pdt(ngrid,nlayer),pdtsrf(ngrid),pdtc(ngrid,nlayer)
+      REAL pdtsrfc(ngrid),pdpsrf(ngrid)
+      REAL piceco2(ngrid),psolaralb(ngrid,2),pemisurf(ngrid)
+
+      REAL pu(ngrid,nlayer) ,  pv(ngrid,nlayer)
+      REAL pdu(ngrid,nlayer) , pdv(ngrid,nlayer)
+      REAL pduc(ngrid,nlayer) , pdvc(ngrid,nlayer)
+      REAL pq(ngridmx,nlayer,nq),pdq(ngrid,nlayer,nq)
+      REAL pdqc(ngrid,nlayer,nq)
+      REAL fluxsurf_sw(ngrid,2) ! added to calculate flux dependent albedo 
+c
+c    Local variables :
+c    -----------------
+
+c   variables used for albedo parametrization       
+c --------------------------------------------      
+      INTEGER i,j
+      REAL Fluxmean(jjp1)
+      INTEGER l,ig,iq,icap,nmix
+      LOGICAL transparency, fluxdependent
+c   flag transparency if you want to make the co2ice semi-transparent       
+      PARAMETER(transparency=.true.)
+c   flag fluxdependent if you want the co2ice albedo to be dependent on
+c   the incident solar flux      
+      PARAMETER(fluxdependent=.false.)
+      REAL slopy,alpha,constA,constB,constT,albediceF_new(ngridmx)
+      REAL zt(ngridmx,nlayermx)
+      REAL zcpi
+      REAL ztcond (ngridmx,nlayermx)
+      REAL ztcondsol(ngridmx) 
+      REAL zdiceco2(ngridmx)
+c      REAL zcondicea(ngridmx,nlayermx) ! Already defined in fisice.h 
+      REAL zcondices(ngridmx)
+      REAL zfallice(ngridmx,nlayermx+1) , zfallheat
+      REAL zmflux(nlayermx+1)
+      REAL zu(nlayermx),zv(nlayermx)
+      REAL zq(nlayermx,nqmx),zq1(nlayermx)
+      REAL ztsrf(ngridmx)
+      REAL ztc(nlayermx), ztm(nlayermx+1) 
+      REAL zum(nlayermx+1) , zvm(nlayermx+1)
+      REAL zqm(nlayermx+1,nqmx),zqm1(nlayermx+1)
+      REAL masse(nlayermx),w(nlayermx+1)
+      REAL Sm(nlayermx),Smq(nlayermx,nqmx),mixmas,qmix
+      LOGICAL condsub(ngridmx)
+
+c variable speciale diagnostique
+      real tconda1(ngridmx,nlayermx)
+      real tconda2(ngridmx,nlayermx)
+c     REAL zdiceco2a(ngridmx) ! for diagnostic only
+      real zdtsig (ngridmx,nlayermx)
+      real zdt (ngridmx,nlayermx)
+
+
+c   local saved variables
+      integer ico2
+      real qco2min
+      save ico2,qco2min
+      REAL emisref(ngridmx)
+      REAL latcond,tcond1mb
+      REAL acond,bcond,ccond,cpice
+      REAL albediceF(ngridmx)
+      SAVE emisref
+      SAVE latcond,acond,bcond,ccond,cpice
+      SAVE albediceF
+ 
+
+      LOGICAL firstcall,firstcall2
+      SAVE firstcall,firstcall2
+      REAL SSUM
+      EXTERNAL SSUM
+
+c      common/scratch/zt,ztcond,zcondicea,zfallice,tconda1
+c     ,    ,tconda2,zdtsig,zdt,zu,zv
+
+
+      DATA latcond,tcond1mb/5.9e5,136.27/
+      DATA cpice /1000./
+      DATA firstcall/.true./
+      DATA firstcall2/.true./
+
+      integer flag
+
+c----------------------------------------------------------------------
+
+c   Initialisation
+c   --------------
+c
+      IF (firstcall) THEN
+         bcond=1./tcond1mb
+         ccond=cpp/(g*latcond)
+         acond=r/latcond
+
+         firstcall=.false.
+         PRINT*,'In newcondens:Tcond(P=1mb)=',tcond1mb,' Lcond=',latcond
+         PRINT*,'acond,bcond,ccond',acond,bcond,acond
+
+         ico2=0
+         if (tracer) then  
+c          Prepare Special treatment if one of the tracer is CO2 gas
+           do iq=1,nqmx
+             if (noms(iq).eq."co2") ico2=iq
+           enddo
+c          minimum CO2 mix. ratio below which mixing occur with layer above: 
+           qco2min =0.75  
+         end if
+      ENDIF
+      zcpi=1./cpp
+c
+c======================================================================
+c    Calcul of CO2 condensation sublimation 
+c    ============================================================
+c  
+c    Used variable :
+c       piceco2(ngrid)   :  amount of co2 ice on the ground (kg/m2)
+c       zcondicea(ngrid,l):  condensation rate in layer  l  (kg/m2/s)
+c       zcondices(ngrid):  condensation rate on the ground (kg/m2/s)
+c       zfallice(ngrid,l):amount of ice falling from layer l (kg/m2/s)
+c                           
+c       pdtc(ngrid,nlayermx)  : dT/dt due to cond/sub
+c
+c
+c     Tendencies set to 0 (except pdtc)
+c     -------------------------------------
+      DO l=1,nlayer
+         DO ig=1,ngrid
+           zcondicea(ig,l) = 0.
+           zfallice(ig,l) = 0.
+           pduc(ig,l)  = 0
+           pdvc(ig,l)  = 0
+         END DO
+      END DO
+         
+      DO iq=1,nqmx         
+      DO l=1,nlayer
+         DO ig=1,ngrid
+           pdqc(ig,l,iq)  = 0
+         END DO
+      END DO
+      END DO
+
+      DO ig=1,ngrid
+         zfallice(ig,nlayer+1) = 0.
+         zcondices(ig) = 0.
+         pdtsrfc(ig) = 0.
+         pdpsrf(ig) = 0.
+         condsub(ig) = .false.
+         zdiceco2(ig) = 0.
+      ENDDO
+      zfallheat=0
+
+c     *************************
+c     ATMOSPHERIC CONDENSATION
+c     *************************
+
+c     forecast of atmospheric temperature zt and frost temperature ztcond
+c     --------------------------------------------------------------------
+
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            zt(ig,l)=pt(ig,l)+ pdt(ig,l)*ptimestep
+            ztcond(ig,l)=1./(bcond-acond*log(.0095*pplay(ig,l)))
+            if (pplay(ig,l).lt.1e-4) ztcond(ig,l)=0.0 !mars Monica
+         ENDDO
+      ENDDO
+ 
+c      Condensation/sublimation in the atmosphere
+c      ------------------------------------------
+c      (calcul of zcondicea , zfallice and pdtc)
+c
+      DO l=nlayer , 1, -1
+         DO ig=1,ngrid
+           pdtc(ig,l)=0.
+           IF((zt(ig,l).LT.ztcond(ig,l)).or.(zfallice(ig,l+1).gt.0))THEN
+               condsub(ig)=.true.
+               IF (zfallice(ig,l+1).gt.0) then  
+                 zfallheat=zfallice(ig,l+1)*
+     &           (pphi(ig,l+1)-pphi(ig,l) +
+     &          cpice*(ztcond(ig,l+1)-ztcond(ig,l)))/latcond
+               ELSE
+                   zfallheat=0.
+               ENDIF
+               pdtc(ig,l)=(ztcond(ig,l) - zt(ig,l))/ptimestep
+               zcondicea(ig,l)=(pplev(ig,l)-pplev(ig,l+1))
+     &                        *ccond*pdtc(ig,l)- zfallheat
+c              Case when the ice from above sublimes entirely
+c              """""""""""""""""""""""""""""""""""""""""""""""
+               IF (zfallice(ig,l+1).lt.- zcondicea(ig,l)) then
+                  pdtc(ig,l)=(-zfallice(ig,l+1)+zfallheat)/
+     &              (ccond*(pplev(ig,l)-pplev(ig,l+1)))
+                  zcondicea(ig,l)= -zfallice(ig,l+1)
+               END IF
+
+               zfallice(ig,l) = zcondicea(ig,l)+zfallice(ig,l+1)
+            END IF
+         ENDDO
+      ENDDO
+
+c     *************************
+c       SURFACE  CONDENSATION
+c     *************************
+
+c     forecast of ground temperature ztsrf and frost temperature ztcondsol
+c     --------------------------------------------------------------------
+      DO ig=1,ngrid
+         ztcondsol(ig)=1./(bcond-acond*log(.0095*pplev(ig,1)))
+         ztsrf(ig) = ptsrf(ig) + pdtsrf(ig)*ptimestep
+      ENDDO
+
+c
+c      Condensation/sublimation on the ground 
+c      --------------------------------------
+c      (calcul of zcondices , pdtsrfc)
+c
+      DO ig=1,ngrid
+         IF(ig.GT.ngrid/2+1) THEN
+            icap=2
+         ELSE
+            icap=1
+         ENDIF
+       
+c
+c        Loop on where we have  condensation/ sublimation 
+         IF ((ztsrf(ig) .LT. ztcondsol(ig)) .OR.   ! ground cond 
+     $       (zfallice(ig,1).NE.0.) .OR.           ! falling snow
+     $      ((ztsrf(ig) .GT. ztcondsol(ig)) .AND.  ! ground sublim.
+     $      ((piceco2(ig)+zfallice(ig,1)*ptimestep) .NE. 0.))) THEN
+            condsub(ig) = .true. 
+
+            IF (zfallice(ig,1).gt.0) then  
+                 zfallheat=zfallice(ig,1)*
+     &           (pphi(ig,1)- phisfi(ig) +
+     &           cpice*(ztcond(ig,1)-ztcondsol(ig)))/(latcond*ptimestep)
+            ELSE
+                 zfallheat=0.
+            ENDIF
+
+c           condensation or partial sublimation of CO2 ice
+c           """""""""""""""""""""""""""""""""""""""""""""""
+            zcondices(ig)=pcapcal(ig)*(ztcondsol(ig)-ztsrf(ig)) 
+     &      /(latcond*ptimestep)         - zfallheat
+            pdtsrfc(ig) = (ztcondsol(ig) - ztsrf(ig))/ptimestep
+       
+c           If the entire CO_2 ice layer sublimes
+c           """"""""""""""""""""""""""""""""""""""""""""""""""""
+c           (including what has just condensed in the atmosphere)
+
+            IF((piceco2(ig)/ptimestep+zfallice(ig,1)).LE.
+     &          -zcondices(ig))THEN
+               zcondices(ig) = -piceco2(ig)/ptimestep - zfallice(ig,1) 
+               pdtsrfc(ig)=(latcond/pcapcal(ig))*
+     &         (zcondices(ig)+zfallheat)
+            END IF
+
+c           Changing CO2 ice amount and pressure :
+c           """"""""""""""""""""""""""""""""""""
+
+            zdiceco2(ig) = zcondices(ig) + zfallice(ig,1)
+            piceco2(ig) = piceco2(ig) + zdiceco2(ig)*ptimestep
+            pdpsrf(ig) = -zdiceco2(ig)*g
+
+            IF(ABS(pdpsrf(ig)*ptimestep).GT.pplev(ig,1)) THEN
+               PRINT*,'STOP in condens'
+               PRINT*,'condensing more than total mass'
+               PRINT*,'Grid point ',ig
+               PRINT*,'Ps = ',pplev(ig,1)
+               PRINT*,'d Ps = ',pdpsrf(ig)
+               STOP
+            ENDIF
+         END IF
+      ENDDO
+
+c  ********************************************************************
+c  Surface albedo and emissivity of the surface below the snow (emisref)
+c  ********************************************************************
+c     Prepare the case where albedo varies with insolation:
+c     ----------------------------------------------------
+      if (fluxdependent) then
+
+c       Calcul du flux moyen (zonal mean)
+        do j=1,jjp1
+           Fluxmean(j)=0      
+           do i=1,iim
+               ig=1+(j-2)*iim +i
+               if(j.eq.1) ig=1
+               if(j.eq.jjp1) ig=ngrid
+               Fluxmean(j)=Fluxmean(j)+fluxsurf_sw(ig,1)
+     $            +fluxsurf_sw(ig,2)
+           enddo
+           Fluxmean(j)=Fluxmean(j)/float(iim)
+        enddo
+
+c       const A and B used to calculate the albedo which depends on solar flux 
+c       albedice=constA+constB*Flux
+c       constT = time step to calculate the solar flux when flux decreases         
+         constA=0.26
+c        constA=0.33
+c        constA=0.186
+         constB=0.00187
+         constT=10
+      endif
+
+c     Calcul de l'albedo
+c     ------------------
+         do ig =1,ngrid
+           IF(ig.GT.ngrid/2+1) THEN
+              icap=2
+           ELSE
+              icap=1
+           ENDIF
+           IF(firstcall2) THEN
+           albediceF(ig)=albedice(icap)
+           ENDIF
+c       test on the existence of co2ice ccccccccccccccccccccccc
+           if(.not.piceco2(ig).ge.0.) THEN
+              if(piceco2(ig).le.-5.e-8) print*,
+     $         'WARNING newcondens piceco2(',ig,')=', piceco2(ig)
+               piceco2(ig)=0.
+           endif
+c       if there is still co2ice        ccccccccccccccccccccccc
+           if (piceco2(ig).gt.0) then
+              emisref(ig) = emisice(icap)
+
+c     if flux dependent albedo is used 
+c     --------------------------------
+             if (fluxdependent) then
+                j=INT((ig-2)/iim)+2
+                if(ig.eq.1) j=1
+                if(ig.eq.ngrid) j=jjp1
+c                albediceF_new(ig)=MIN(constA+constB*Fluxmean(j),
+c     $          constA+constB*250)
+                  albediceF_new(ig)=constA+constB*Fluxmean(j)
+                if (albediceF(ig).gt.albediceF_new(ig)) then
+                   albediceF(ig)=albediceF(ig)+ ptimestep/(daysec*
+     $             constT)*(albediceF_new(ig)-albediceF(ig))
+                else
+                   albediceF(ig)=albediceF_new(ig)
+                endif
+c               if part of the ice is transparent
+c               slopy = pente de la droite:  alpha = y*co2ice/1620
+c               pour une valeur superieur a une epaisseur de glace donnee
+c               ici, epaisseur limite = 10cm
+                if (transparency) then
+                slopy=1/(1620*0.10)
+                alpha=MIN(slopy*piceco2(ig),1.)
+                psolaralb(ig,1) = alpha*albediceF(ig)
+     $                           +(1-alpha)*albedodat(ig) 
+                psolaralb(ig,2) = psolaralb(ig,1) 
+                else
+                psolaralb(ig,1) = albediceF(ig) 
+                psolaralb(ig,2) = psolaralb(ig,1) 
+                endif
+             else
+c           transparency set to true and fluxdependent set to false            
+                if (transparency) then
+                slopy=1/(1620*0.10)
+                alpha=MIN(slopy*piceco2(ig),1.)
+                psolaralb(ig,1) = alpha*albedice(icap)
+     $                           +(1-alpha)*albedodat(ig) 
+                psolaralb(ig,2) = psolaralb(ig,1) 
+                else
+c           simplest case: transparency and flux dependent set to false
+                psolaralb(ig,1) = albedice(icap)
+                psolaralb(ig,2) = albedice(icap)
+                endif
+             endif    
+c         no more co2ice, albedo = ground albedo
+           else
+              psolaralb(ig,1) = albedodat(ig)
+              psolaralb(ig,2) = albedodat(ig)
+              emisref(ig) = emissiv
+              pemisurf(ig) = emissiv
+           endif
+         end do ! end of the ig loop
+
+         firstcall2=.false.
+c ***************************************************************
+c  Correction to account for redistribution between sigma or hybrid 
+c  layers when changing surface pressure (and warming/cooling
+c  of the CO2 currently changing phase).
+c *************************************************************
+
+      DO ig=1,ngrid
+        if (condsub(ig)) then
+           do l=1,nlayer
+             ztc(l)  =zt(ig,l)   +pdtc(ig,l)  *ptimestep
+             zu(l)   =pu(ig,l)   +pdu( ig,l)  *ptimestep
+             zv(l)   =pv(ig,l)   +pdv( ig,l)  *ptimestep
+            do iq=1,nqmx
+             zq(l,iq)=pq(ig,l,iq)+pdq(ig,l,iq)*ptimestep
+            enddo
+           end do
+
+c  Mass fluxes through the sigma levels (kg.m-2.s-1)  (>0 when up)
+c  """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
+
+            zmflux(1) = -zcondices(ig)
+            DO l=1,nlayer
+             zmflux(l+1) = zmflux(l) -zcondicea(ig,l)
+     &        + (bp(l)-bp(l+1))*(zfallice(ig,1)-zmflux(1))
+c zmflux set to 0 if very low to avoid: top layer is disappearing in v1ld  
+          if (abs(zmflux(l+1)).lt.1E-13.OR.bp(l+1).eq.0.) zmflux(l+1)=0.
+            END DO
+
+c Mass of each layer
+c ------------------ 
+            DO l=1,nlayer
+              masse(l)=(pplev(ig,l) - pplev(ig,l+1))/g
+            END DO
+
+
+c  Corresponding fluxes for T,U,V,Q
+c  """"""""""""""""""""""""""""""""
+
+c           averaging operator for TRANSPORT  
+c           """"""""""""""""""""""""""""""""
+c           Value transfert at the surface interface when condensation
+c           sublimation:
+            ztm(1) = ztsrf(ig) + pdtsrfc(ig)*ptimestep
+            zum(1) = 0  
+            zvm(1) = 0  
+            do iq=1,nqmx
+              zqm(1,iq)=0. ! most tracer do not condense !
+            enddo
+c           Special case if one of the tracer is CO2 gas
+            if (ico2.ne.0) zqm(1,ico2)=1. ! flux is 100% CO2
+
+c           Van Leer scheme:
+            DO l=1,nlayer+1
+                w(l)=-zmflux(l)*ptimestep
+            END DO
+            call vl1d(ztc,2.,masse,w,ztm) 
+            call vl1d(zu ,2.,masse,w,zum) 
+            call vl1d(zv ,2.,masse,w,zvm) 
+            do iq=1,nqmx
+             do l=1,nlayer
+              zq1(l)=zq(l,iq)
+             enddo
+             zqm1(1)=zqm(1,iq)
+             call vl1d(zq1,2.,masse,w,zqm1)
+             do l=2,nlayer
+              zq( l,iq)=zq1(l)
+              zqm(l,iq)=zqm1(l)
+             enddo
+            enddo
+
+c           Surface condensation affects low winds
+            if (zmflux(1).lt.0) then 
+                zum(1)= zu(1) *  (w(1)/masse(1))
+                zvm(1)= zv(1) *  (w(1)/masse(1))
+                if (w(1).gt.masse(1)) then ! ensure numerical stability
+                  zum(1)= (zu(1)-zum(2))*masse(1)/w(1) + zum(2)
+                  zvm(1)= (zv(1)-zvm(2))*masse(1)/w(1) + zvm(2)
+                end if
+            end if
+                    
+            ztm(nlayer+1)= ztc(nlayer) ! should not be used, but... 
+            zum(nlayer+1)= zu(nlayer)  ! should not be used, but...
+            zvm(nlayer+1)= zv(nlayer)  ! should not be used, but...
+            do iq=1,nqmx
+             zqm(nlayer+1,iq)= zq(nlayer,iq)
+            enddo
+  
+c           Tendencies on T, U, V, Q 
+c           """"""""""""""""""""""""
+            DO l=1,nlayer
+ 
+c             Tendencies on T
+                zdtsig(ig,l) = (1/masse(l)) *
+     &        ( zmflux(l)*(ztm(l) - ztc(l)) 
+     &        - zmflux(l+1)*(ztm(l+1) - ztc(l))
+     &        + zcondicea(ig,l)*(ztcond(ig,l)-ztc(l))  )
+                pdtc(ig,l) =  pdtc(ig,l) + zdtsig(ig,l)
+
+c             Tendencies on U
+                pduc(ig,l)   = (1/masse(l)) *
+     &        ( zmflux(l)*(zum(l) - zu(l))
+     &        - zmflux(l+1)*(zum(l+1) - zu(l)) )
+
+
+c             Tendencies on V
+                pdvc(ig,l)   = (1/masse(l)) *
+     &        ( zmflux(l)*(zvm(l) - zv(l))
+     &        - zmflux(l+1)*(zvm(l+1) - zv(l)) )
+
+            END DO
+
+c           Tendencies on Q
+            do iq=1,nqmx
+              if (noms(iq).eq.'co2') then 
+c               SPECIAL Case when the tracer IS CO2 :
+                DO l=1,nlayer
+                  pdqc(ig,l,iq)= (1/masse(l)) *
+     &           ( zmflux(l)*(zqm(l,iq) - zq(l,iq))
+     &           - zmflux(l+1)*(zqm(l+1,iq) - zq(l,iq)) 
+     &           + zcondicea(ig,l)*(zq(l,iq)-1.) )
+                END DO
+              else
+                DO l=1,nlayer
+                  pdqc(ig,l,iq)= (1/masse(l)) *
+     &           ( zmflux(l)*(zqm(l,iq) - zq(l,iq))
+     &           - zmflux(l+1)*(zqm(l+1,iq) - zq(l,iq)) 
+     &           + zcondicea(ig,l)*zq(l,iq) )
+                END DO
+              end if
+            enddo
+
+c           --------------------------------------------------------
+c           Roughly Simulate Molecular mixing when CO2 is too depleted by
+c           Surface condensation (mixing starts if qco2 < qco2min )  
+c           FF 06/2004
+c           WARNING : this is now done in convadj, better (FF 02/2005)
+c           --------------------------------------------------------
+            flag=0  ! now done in convadj : must be =0
+            if (flag.eq.1) then 
+            if(ico2.gt.0) then   ! relevant only if one tracer is CO2
+             if(pq(ig,1,ico2)+(pdq(ig,1,ico2)+pdqc(ig,1,ico2))*ptimestep
+     &       .lt.qco2min) then 
+                do iq=1,nqmx
+                  zq(1,iq)=pq(ig,1,iq)
+     &                     +(pdq(ig,1,iq)+pdqc(ig,1,iq))*ptimestep
+                  Smq(1,iq) = masse(1)*zq(1,iq)
+                end do
+                Sm(1)  = masse(1)
+                do l =2,nlayermx
+                  do iq=1,nqmx
+                     zq(l,iq)=pq(ig,l,iq)
+     &                        +(pdq(ig,l,iq)+pdqc(ig,l,iq))*ptimestep
+                     smq(l,iq) = smq(l-1,iq) + masse(l)*zq(l,iq)
+                  end do 
+                  sm(l) = sm(l-1) + masse(l)
+                  if(zq(l,ico2).gt.qco2min) then 
+c                   mixmas: mass of atmosphere that must be mixed to reach qco2min
+                    mixmas = (sm(l-1)*zq(l,ico2)-Smq(l-1,ico2))
+     &                      /(zq(l,ico2)-qco2min)
+                    if((mixmas.le.sm(l)))then
+c                      OK if mixed mass less than mass of layers affected
+                       nmix=l   ! number of layer affected by mixing
+                       goto 99 
+                    end if
+                  end if
+                 end do
+ 99              continue 
+                 do iq=1,nqmx
+                   qmix=zq(nmix,iq) 
+     &             +(Smq(nmix-1,iq)-zq(nmix,iq)*Sm(nmix-1))/mixmas
+                   do l=1,nmix-1
+                      pdqc(ig,l,iq)=
+     &                  (qmix-pq(ig,l,iq))/ptimestep - pdq(ig,l,iq)
+                   end do 
+c                  layer only partly mixed :
+                   pdqc(ig,nmix,iq)=(
+     &             qmix+(Sm(nmix)-mixmas)*(zq(nmix,iq)-qmix)/masse(nmix)
+     &             -pq(ig,nmix,iq))/ptimestep -pdq(ig,nmix,iq)
+
+                 end do 
+             end if
+            end if
+
+        endif   ! (flag.eq.1)
+       end if ! if (condsub)
+      END DO  ! loop on ig 
+
+c ***************************************************************
+c   CO2 snow / clouds scheme
+c ***************************************************************
+
+      call co2snow(ngrid,nlayer,ptimestep,emisref,condsub,pplev,
+     &        zcondicea,zcondices,zfallice,pemisurf)
+
+c ***************************************************************
+c Ecriture des diagnostiques
+c ***************************************************************
+
+c     DO l=1,nlayer
+c        DO ig=1,ngrid
+c         Taux de cond en kg.m-2.pa-1.s-1
+c          tconda1(ig,l)=zcondicea(ig,l)/(pplev(ig,l)-pplev(ig,l+1))
+c          Taux de cond en kg.m-3.s-1
+c          tconda2(ig,l)=tconda1(ig,l)*pplay(ig,l)*g/(r*pt(ig,l))
+c        END DO
+c     END DO
+c     call WRITEDIAGFI(ngridmx,'tconda1',
+c    &'Taux de condensation CO2 atmospherique /Pa',
+c    & 'kg.m-2.Pa-1.s-1',3,tconda1)
+c     call WRITEDIAGFI(ngridmx,'tconda2',
+c    &'Taux de condensation CO2 atmospherique /m',
+c    & 'kg.m-3.s-1',3,tconda2)
+
+      return
+      end
+
+
+
+c *****************************************************************
+      SUBROUTINE vl1d(q,pente_max,masse,w,qm)
+c
+c    
+c     Operateur de moyenne inter-couche pour calcul de transport type
+c     Van-Leer " pseudo amont " dans la verticale
+c    q,w sont des arguments d'entree  pour le s-pg ....
+c    masse : masse de la couche Dp/g
+c    w : masse d'atm ``transferee'' a chaque pas de temps (kg.m-2)
+c    pente_max = 2 conseillee
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+
+#include "dimensions.h"
+
+c
+c
+c
+c   Arguments:
+c   ----------
+      real masse(llm),pente_max
+      REAL q(llm),qm(llm+1)
+      REAL w(llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER l
+c
+      real dzq(llm),dzqw(llm),adzqw(llm),dzqmax
+      real sigw, Mtot, MQtot
+      integer m 
+c     integer ismax,ismin 
+
+
+c    On oriente tout dans le sens de la pression 
+c     W > 0 WHEN DOWN !!!!!!!!!!!!!
+
+      do l=2,llm
+            dzqw(l)=q(l-1)-q(l)
+            adzqw(l)=abs(dzqw(l))
+      enddo
+
+      do l=2,llm-1
+            if(dzqw(l)*dzqw(l+1).gt.0.) then
+                dzq(l)=0.5*(dzqw(l)+dzqw(l+1))
+            else
+                dzq(l)=0.
+            endif
+            dzqmax=pente_max*min(adzqw(l),adzqw(l+1))
+            dzq(l)=sign(min(abs(dzq(l)),dzqmax),dzq(l))
+      enddo
+
+         dzq(1)=0.
+         dzq(llm)=0.
+
+       do l = 1,llm-1
+
+c         Regular scheme (transfered mass < layer mass)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(w(l+1).gt.0. .and. w(l+1).le.masse(l+1)) then
+             sigw=w(l+1)/masse(l+1)
+             qm(l+1)=(q(l+1)+0.5*(1.-sigw)*dzq(l+1))
+          else if(w(l+1).le.0. .and. -w(l+1).le.masse(l)) then
+             sigw=w(l+1)/masse(l)
+             qm(l+1)=(q(l)-0.5*(1.+sigw)*dzq(l))
+
+c         Extended scheme (transfered mass > layer mass)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else if(w(l+1).gt.0.) then
+             m=l+1
+             Mtot = masse(m)
+             MQtot = masse(m)*q(m)
+             do while ((m.lt.llm).and.(w(l+1).gt.(Mtot+masse(m+1))))
+                m=m+1
+                Mtot = Mtot + masse(m)
+                MQtot = MQtot + masse(m)*q(m)
+             end do
+             if (m.lt.llm) then
+                sigw=(w(l+1)-Mtot)/masse(m+1)
+                qm(l+1)= (1/w(l+1))*(MQtot + (w(l+1)-Mtot)*
+     &          (q(m+1)+0.5*(1.-sigw)*dzq(m+1)) )
+             else
+                w(l+1) = Mtot
+                qm(l+1) = Mqtot / Mtot
+                write(*,*) 'top layer is disapearing !'
+                stop
+             end if
+          else      ! if(w(l+1).lt.0) 
+             m = l-1 
+             Mtot = masse(m+1)
+             MQtot = masse(m+1)*q(m+1)
+             do while ((m.gt.0).and.(-w(l+1).gt.(Mtot+masse(m))))
+                m=m-1
+                Mtot = Mtot + masse(m+1)
+                MQtot = MQtot + masse(m+1)*q(m+1)
+             end do
+             if (m.gt.0) then
+                sigw=(w(l+1)+Mtot)/masse(m)
+                qm(l+1)= (-1/w(l+1))*(MQtot + (-w(l+1)-Mtot)* 
+     &          (q(m)-0.5*(1.+sigw)*dzq(m))  )
+             else
+                qm(l+1)= (-1/w(l+1))*(MQtot + (-w(l+1)-Mtot)*qm(1))
+             end if   
+          end if
+       enddo
+
+c     boundary conditions (not used in newcondens !!)
+c         qm(llm+1)=0.
+c         if(w(1).gt.0.) then
+c            qm(1)=q(1)
+c         else 
+c           qm(1)=0.
+c         end if
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newsedim.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newsedim.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/newsedim.F	(revision 57)
@@ -0,0 +1,185 @@
+      SUBROUTINE newsedim(ngrid,nlay,nsize,ptimestep,
+     &  pplev,masse,epaisseur,pt,rd,rho,pqi,wq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c      Compute sedimentation of 1 tracer 
+c      of radius rd (m) and density rho (kg.m-3) 
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,nsize
+      REAL ptimestep            ! pas de temps physique (s)
+      REAL pplev(ngrid,nlay+1)   ! pression aux inter-couches (Pa)
+      REAL pt(ngrid,nlay)    ! temperature au centre des couches (K)
+      real masse (ngrid,nlay) ! masse d'une couche (kg)
+      real epaisseur (ngrid,nlay)  ! epaisseur d'une couche (m)
+      real rd(nsize)             ! particle radius (m)
+      real rho             ! particle density (kg.m-3)
+
+
+c    Traceurs :
+      real pqi(ngrid,nlay)  ! traceur   (e.g. ?/kg)
+      real wq(ngridmx,nlay+1)  ! flux de traceur durant timestep (?/m-2)
+      
+c   local:
+c   ------
+
+      INTEGER l,ig, k, i
+      REAL rfall
+
+      LOGICAL firstcall
+      SAVE firstcall
+
+c    Traceurs :
+c    ~~~~~~~~ 
+      real traversee (ngridmx,nlayermx)
+      real vstokes(ngridmx,nlayermx)
+      real w(ngridmx,nlayermx)
+      real ptop, dztop, Ep, Stra
+
+      DATA firstcall/.true./
+
+c    Physical constant
+c    ~~~~~~~~~~~~~~~~~
+      REAL visc, molrad
+c     Gas molecular viscosity (N.s.m-2)
+      data visc/1.e-5/       ! CO2
+c     Effective gas molecular radius (m)
+      data molrad/2.2e-10/   ! CO2
+
+c     local and saved variable
+      real a,b
+      save a,b
+
+
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+         IF(ngrid.NE.ngridmx) THEN
+            PRINT*,'STOP dans newsedim'
+            PRINT*,'probleme de dimensions :'
+            PRINT*,'ngrid  =',ngrid
+            PRINT*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+         firstcall=.false.
+
+
+c       Preliminary calculations for sedimenation velocity :
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+c       - Constant to compute stokes speed simple formulae
+c        (Vstokes =  b * rho* r**2   avec   b= (2/9) * rho * g / visc
+         b = 2./9. * g / visc
+
+c       - Constant  to compute gas mean free path
+c        l= (T/P)*a, avec a = (  0.707*8.31/(4*pi*molrad**2 * avogadro))
+         a = 0.707*8.31/(4*3.1416* molrad**2  * 6.023e23)
+
+c       - Correction to account for non-spherical shape (Murphy et al.  1990)
+c   (correction = 0.85 for irregular particles, 0.5 for disk shaped particles)
+c        a = a    * 0.85
+      ENDIF
+
+
+
+
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+
+c     Sedimentation velocity (m/s)
+c     ~~~~~~~~~~~~~~~~~~~~~~
+c     (stokes law corrected for low pressure by the Cunningham
+c     slip-flow correction  according to Rossow (Icarus 36, 1-50, 1978)
+
+        do  l=1,nlay
+          do ig=1, ngrid
+            if (nsize.eq.1) then 
+              rfall=rd(1)
+            else
+              i=ngrid*(l-1)+ig
+              rfall=rd(i)
+            endif  
+            vstokes(ig,l) = b * rho * rfall**2 *
+     &      (1 + 1.333* ( a*pt(ig,l)/pplev(ig,l) )/rfall)
+
+c           Layer crossing time (s) :
+            traversee(ig,l)= epaisseur(ig,l)/vstokes(ig,l)
+          end do
+        end do
+
+
+c     Calcul de la masse d'atmosphere correspondant a q transferee
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     (e.g. on recherche le niveau  en dessous de laquelle le traceur
+c      va traverser le niveau intercouche l : "dztop" est sa hauteur
+c      au dessus de l (m), "ptop" est sa pression (Pa))
+
+      do  l=1,nlay
+        do ig=1, ngrid
+             
+             dztop = vstokes(ig,l)*  ptimestep 
+             Ep=0
+             k=0
+
+c **************************************************************
+c            Simple Method
+             w(ig,l) =
+     &       (1- exp(-dztop*g/(r*pt(ig,l))))*pplev(ig,l) / g
+cc           write(*,*) 'OK simple method l,w =', l, w(ig,l)
+cc           write(*,*) 'OK simple method dztop =', dztop
+c **************************************************************
+cccc         Complex method :
+            if (dztop.gt.epaisseur(ig,l)) then
+cccc            Cas ou on "epuise" la couche l : On calcule le flux
+cccc            Venant de dessus en tenant compte de la variation de Vstokes
+
+               Ep= epaisseur(ig,l)
+               Stra= traversee(ig,l)
+               do while(dztop.gt.Ep.and.l+k+1.le.nlay)
+                 k=k+1
+                 dztop= Ep + vstokes(ig,l+k)*(ptimestep -Stra)
+                 Ep = Ep + epaisseur(ig,l+k)
+                 Stra = Stra + traversee(ig,l+k)
+               enddo 
+               Ep = Ep - epaisseur(ig,l+k)
+             end if
+             ptop=pplev(ig,l+k)*exp(-(dztop-Ep)*g/(r*pt(ig,l+k)))
+             w(ig,l) = (pplev(ig,l) -Ptop)/g
+c
+cc           write(*,*) 'OK new    method l,w =', l, w(ig,l)
+cc           write(*,*) 'OK new    method dztop =', dztop
+cc       if(l.eq.7)write(*,*)'l=7,k,pplev,Ptop',pplev(ig,l),Ptop
+cc       if(l.eq.7)write(*,*)'l=7,dztop,Ep',dztop,Ep
+cc            if(l.eq.6)write(*,*)'l=6,k, w',k, w(1,l)
+cc            if(l.eq.7)write(*,*)'l=7,k, w',k, w(1,l)
+cc            if(l.eq.8)write(*,*)'l=8,k, w',k, w(1,l)
+c **************************************************************
+        end do
+      end do
+
+      call vlz_fi(ngrid,pqi,2.,masse,w,wq)
+c         write(*,*) ' newsed: wq(6), wq(7), q(6)',
+c    &                wq(1,6),wq(1,7),pqi(1,6)
+
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nirco2abs.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nirco2abs.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nirco2abs.F	(revision 57)
@@ -0,0 +1,144 @@
+      SUBROUTINE nirco2abs(ngrid,nlayer,pplay,dist_sol,
+     $     mu0,fract,declin,pdtnirco2)
+                                                   
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing heating rate due to
+c   absorption by CO2 in the near-infrared
+c   This version includes NLTE effects
+c
+c   (Scheme to be described in Forget et al., JGR, 2003)
+c   (old Scheme described in Forget et al., JGR, 1999)
+c
+c   This version updated with a new functional fit,
+c   see NLTE correction-factor of Lopez-Valverde et al (1998)
+c   Stephen Lewis 2000
+c  
+c   08/2002 : correction for bug when running with diurnal=F
+c
+c   author:  Frederic Hourdin 1996 
+c   ------
+c            Francois Forget 1999 
+c
+c   input:
+c   ----- 
+c   ngrid                 number of gridpoint of horizontal grid
+c   nlayer                Number of layer
+c   dist_sol              sun-Mars distance (AU)
+c   mu0(ngridmx)          
+c   fract(ngridmx)        day fraction of the time interval
+c   declin                latitude of subslar point
+c
+c   output:
+c   -------
+c
+c   pdtnirco2(ngrid,nlayer)      Heating rate (K/s)
+c
+c
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+c
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "comdiurn.h"
+
+
+c-----------------------------------------------------------------------
+c    Input/Output
+c    ------------
+      INTEGER ngrid,nlayer
+
+      REAL pplay(ngrid,nlayer)
+      REAL dist_sol,mu0(ngridmx),fract(ngridmx),declin
+
+      REAL pdtnirco2(ngrid,nlayer)
+c
+c    Local variables :
+c    -----------------
+      INTEGER l,ig, n, nstep
+      REAL co2heat0, zmu(ngridmx)
+
+c     special diurnal=F 
+      real mu0_int(ngridmx),fract_int(ngridmx),zday_int
+      real ztim1,ztim2,ztim3,step
+
+c
+c   local saved variables
+c   ---------------------
+
+c     p0noonlte is a pressure below which non LTE effects are significant.
+c     REAL p0nonlte
+c     DATA p0nonlte/7.5e-3/
+c     SAVE p0nonlte
+
+c     parameters for CO2 heating fit
+      real n_a, n_p0, n_b
+      parameter (n_a=1.1956475)
+      parameter (n_b=1.9628251)
+      parameter (n_p0=0.0015888279)
+
+c----------------------------------------------------------------------
+
+c     Initialisation
+c     --------------
+c     co2heat is the heating by CO2 at 700Pa for a zero zenithal angle.
+      co2heat0=n_a*(1.52/dist_sol)**2/daysec
+
+c     Simple calcul for a given sun incident angle (if diurnal=T)
+c     --------------------------------------------
+
+      IF (diurnal) THEN  
+         do ig=1,ngrid
+            zmu(ig)=sqrt(1224.*mu0(ig)*mu0(ig)+1.)/35.
+         enddo
+         do l=1,nlayer
+           do ig=1,ngrid
+             if(fract(ig).gt.0.) pdtnirco2(ig,l)=
+     &             co2heat0*sqrt((700.*zmu(ig))/pplay(ig,l))
+     &             /(1.+n_p0/pplay(ig,l))**n_b
+
+c           OLD SCHEME (forget et al. 1999)
+c    s           co2heat0*sqrt((700.*zmu(ig))/pplay(ig,l))
+c    s          / (1+p0nonlte/pplay(ig,l))
+           enddo
+         enddo
+
+c     Averaging over diurnal cycle (if diurnal=F)
+c     -------------------------------------------
+c     NIR CO2 abs is slightly non linear. To remove the diurnal
+c     cycle, it is better to average the heating rate over 1 day rather
+c     than using the mean mu0 computed by mucorr in physiq.F (FF, 1998)
+
+      ELSE      ! if (.not.diurnal) then
+
+         nstep = 20   ! number of integration step /sol
+         do n=1,nstep
+            zday_int = (n-1)/float(nstep)
+            ztim2=COS(declin)*COS(2.*pi*(zday_int-.5))
+            ztim3=-COS(declin)*SIN(2.*pi*(zday_int-.5))
+            CALL solang(ngrid,sinlon,coslon,sinlat,coslat,
+     s             ztim1,ztim2,ztim3,
+     s             mu0_int,fract_int)
+            do ig=1,ngrid
+               zmu(ig)=sqrt(1224.*mu0_int(ig)*mu0_int(ig)+1.)/35.
+            enddo
+            do l=1,nlayer
+               do ig=1,ngrid
+                  if(fract_int(ig).gt.0.) pdtnirco2(ig,l)=
+     &                 pdtnirco2(ig,l) + (1/float(nstep))*
+     &                 co2heat0*sqrt((700.*zmu(ig))/pplay(ig,l))
+     &                 /(1.+n_p0/pplay(ig,l))**n_b
+               enddo
+            enddo
+         end do
+      END IF
+
+      return
+      end 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltecool.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltecool.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltecool.F	(revision 57)
@@ -0,0 +1,306 @@
+c**************************************************************************
+c
+      subroutine nltecool(ngrid,nlayer,pplay,pt,dtnlte)
+c
+c This code was designed as a delivery for the "Martian Environment Models" 
+c project ( ESA contract 11369/95/nl/jg CCN2 )
+c Computes non-LTE heating rates from CO2 emission at 15 um
+c in the Martian upper atmosphere.
+c Uses a simplified model consisting of two excited levels with two
+c emission bands, one of them stronger than the other, which correspond
+c to the behaviours of the 626 fundamental band and the isotopic fund.bands.
+c It uses a cool-to-space approximation with tabulated escape functions.
+c These escape functions have been precomputed for the strong and weak bands,
+c and are given as a function of pressure in separate files.
+c The output values are the heating rates (actually, cooling, since they
+c are always negative) for the two bands, i.e., the total cooling is the
+c sum of them.
+c Miguel A. Lopez Valverde
+c Instituto de Astrofisica de Andalucia (CSIC), Granada, Spain
+c
+c Version 1b.  See description above.  22-March-2000.
+c Adapted as a subroutine for use in GCM -- PLR/SRL 6/2000
+c Version 1c.  Inclusion of VMR in the tabulation of escape functions. 
+c              Table contains now only 1 input file -- Miguel 11/Jul/2000
+c Version 1d  data contained in original input file "nlte_escape.dat"
+c now stored in include file "nltedata.h" Y.Wanherdrick 09/2000
+c     
+c***************************************************************************
+
+      implicit none
+
+#include "nltedata.h" ! (Equivalent to the reading of the "nlte_escape.dat" file)
+ 
+c Input and output variables
+c
+      integer     ngrid                           ! no. of horiz. gridpoints
+      integer     nlayer                          ! no. of atmospheric layers
+      real        pplay(ngrid,nlayer)             ! input pressure grid
+      real        pt(ngrid,nlayer)                ! input temperatures
+      real        dtnlte(ngrid,nlayer)            ! output temp. tendencies
+
+c
+c Standard atmosphere variables
+c
+      real        nt                              ! number density [cm-3]
+      real        co2(nlayer)                     !  "   of CO2
+      real        o3p(nlayer)                     !  "   of atomic oxygen
+      real        n2co(nlayer)                    !  "  of N2 + CO
+      real        pyy(nlayer)                     ! auxiliary pressure grid
+
+c
+c Vectors and indexes for the tabulation of escape functions and VMR
+c
+c                 np                              ! # data points in tabulation
+c                 pnb(np)                         ! Pressure in tabulation
+c                 ef1(np)                         ! Esc.funct.#1, tabulated
+c                 ef2(np)                         ! Esc.funct.#2, tabulated
+c                 co2vmr(np)                      ! CO2 VMR tabulated
+c                 o3pvmr(np)                      ! CO2 VMR tabulated
+c                 n2covmr(np)                     ! N2+CO VMR tabulated
+      real        escf1(nlayer)                   ! Esc.funct.#1, interpolated
+      real        escf2(nlayer)                   ! Esc.funct.#2, interpolated
+
+
+c
+c Local Constants
+c
+      real       nu1, nu2                         ! freq. of energy levels
+      real       imr1, imr2                       ! isotopic abundances
+      real       hplanck, gamma, vlight           ! physical constants
+      real       ee
+      real       rfvt                             ! collisional rate
+      real       rfvto3p                          !     "
+      real       rfvv                             !     "
+
+c
+c Local variables for the main loop
+c
+      real       n1, n2, co2t                     ! ground populations
+      real       l1, p1, p12                      ! prod & losses
+      real       l2, p2, p21
+      real       tt                               ! dummy variable
+      real       c1, c2                           ! molecular constants
+      real       ae1, ae2                         ! einstein spontaneous emission
+      real       a1, a2, a12, a21
+      real       pl1, pl2
+      real       el1, el2
+      real       hr1, hr2                         ! heating rate due to each band
+      real       hr(nlayer)                       ! total heating rate
+
+c
+c Indexes
+c
+      integer    i
+      integer    j,ii
+
+c
+c Rate coefficients
+c
+      real       k19xca, k19xcb
+      real       k19cap1, k19cap2
+      real       k19cbp1, k19cbp2
+      real       d19c, d19cp1, d19cp2
+      real       k20xc, k20cp1, k20cp2
+      real       k21xc, k21cp2
+
+      logical    firstcall
+      data       firstcall/.true./
+      save       firstcall,ef1,ef2,co2vmr,n2covmr,o3pvmr,pnb
+
+c
+c Data
+c
+      data       nu1, nu2, hplanck, gamma, vlight, ee/
+     1     667.38, 662.3734, 6.6261e-27, 1.191e-5, 3.e10, 1.438769/
+
+c*************************************************************************
+c       PROGRAM  STARTS
+c*************************************************************************
+
+      imr1 = 0.987
+      imr2 = 0.00408 + 0.0112
+      rfvt = 0.1
+      rfvto3p = 1.0
+      rfvv = 0.1
+
+      if(firstcall) then
+
+         do i=1,np
+            pnb(i)=1.0e-4*exp(pnb(i)) ! p into Pa
+         end do
+
+         firstcall = .false.
+
+      endif
+
+c
+c MAIN LOOP, for each gridpoint and altitude:
+c
+      do j=1,ngrid  ! loop over grid points
+c
+c set up local pressure grid
+c
+         do ii=1,nlayer
+            pyy(ii)=pplay(j,ii)
+         enddo
+!
+! Interpolate escape functions and VMR to the desired grid
+!
+         call interp1(escf2,pyy,nlayer,ef2,pnb,np)
+         call interp1(escf1,pyy,nlayer,ef1,pnb,np)
+         call interp3(co2,o3p,n2co,pyy,nlayer,
+     &        co2vmr,o3pvmr,n2covmr,pnb,np)
+        
+         do i=1,nlayer  ! loop over layers
+C
+C test if p lies outside range (p > 3.5 Pa)
+C changed to 1 Pa since transition will always be higher than this
+C
+            if(pyy(i) .gt. 1.0 .or. pyy(i) .lt. 4.0e-6) then 
+               hr(i)=0.0
+               dtnlte(j,i)=0.0
+            else
+c
+c           if(pt(j,i).lt.1.0)print*,pt(j,i)
+               nt = pyy(i)/(1.381e-17*pt(j,i)) ! nt in cm-3
+               co2(i)=co2(i)*nt                ! CO2 density in cm-3
+               o3p(i)=o3p(i)*nt                ! O3p density in cm-3
+               n2co(i)=n2co(i)*nt              ! N2+CO in cm-3
+c molecular populations
+               n1 = co2(i) * imr1
+               n2 = co2(i) * imr2
+               co2t = n1 + n2
+
+c intermediate collisional rates
+               tt = pt(j,i)*pt(j,i)
+
+               if (pt(j,i).le.175.0) then
+                  k19xca = 3.3e-15
+                  k19xcb = 7.6e-16
+               else
+                  k19xca = 4.2e-12 * exp( -2988.0/pt(j,i) + 303930.0/tt)
+                  k19xcb = 2.1e-12 * exp( -2659.0/pt(j,i) + 223052.0/tt)
+               endif
+               k19xca = k19xca * rfvt
+               k19xcb = k19xcb * rfvt
+               k19cap1 = k19xca * 2.0 * exp( -ee*nu1/pt(j,i) )
+               k19cap2 = k19xca * 2.0 * exp( -ee*nu2/pt(j,i) )
+               k19cbp1 = k19xcb * 2.0 * exp( -ee*nu1/pt(j,i) )
+               k19cbp2 = k19xcb * 2.0 * exp( -ee*nu2/pt(j,i) )
+               d19c = k19xca*co2t + k19xcb*n2co(i)
+               d19cp1 = k19cap1*co2t + k19cbp1*n2co(i)
+               d19cp2 = k19cap2*co2t + k19cbp2*n2co(i)
+                                !
+               k20xc = 3.e-12 * rfvto3p
+               k20cp1 = k20xc * 2.0 * exp( -ee/pt(j,i) * nu1 )
+               k20cp2 = k20xc * 2.0 * exp( -ee/pt(j,i) * nu2 )
+                                !
+               k21xc = 2.49e-11 * 0.5 * rfvv
+               k21cp2 = k21xc * exp( - ee/pt(j,i) * (nu2-nu1) )
+                                !
+               l1 = d19c + k20xc*o3p(i) + k21cp2*n2
+               p1 = ( d19cp1 + k20cp1*o3p(i) ) * n1
+               p12 = k21xc*n1
+                                !
+               l2 = d19c + k20xc*o3p(i) + k21xc*n1
+               p2 = ( d19cp2 + k20cp2*o3p(i) ) * n2
+               p21 = k21cp2*n2
+
+c radiative rates
+               ae1 = 1.3546 * 1.66 / 4.0 * escf1(i)
+               ae2 = ( 1.3452 + 1.1878 ) * 1.66 / 4.0 * escf2(i)
+               l1 = l1 + ae1
+               l2 = l2 + ae2
+
+c solving the system
+               c1 = gamma*nu1**3. * 0.5
+               c2 = gamma*nu2**3. * 0.5
+               a1 = c1 * p1 / (n1*l1)
+               a2 = c2 * p2 / (n2*l2)
+               a12 = (nu1/nu2)**3. * n2/n1 * p12/l1
+               a21 = (nu2/nu1)**3. * n1/n2 * p21/l2
+               el2 = (a2 + a21 * a1 ) / ( 1.0 - a21 * a12 )
+               el1 = a1 + a12 * el2
+               pl1 = el1 * n1 / c1
+               pl2 = el2 * n2 / c2
+
+c  heating rate
+               hr1 = - hplanck*vlight * nu1 * ae1 * pl1
+               hr2 = - hplanck*vlight * nu2 * ae2 * pl2
+               hr(i) = hr1 + hr2
+               dtnlte(j,i)=0.1*hr(i)*pt(j,i)/(4.4*pyy(i)) ! dtnlte in K s-1
+c              write(7,25)pxx(i),hr1,hr2,hr(i),qt
+c  25         format(' ',1p5e12.4)
+
+            endif
+
+         enddo  ! end loop over layers
+      enddo     ! end loop over grid points
+c     close(7)
+c
+        return
+        end
+
+c***********************************************************************
+
+      subroutine interp1(escout,p,nlayer,escin,pin,nl)
+C
+C subroutine to perform linear interpolation in pressure from 1D profile 
+C escin(nl) sampled on pressure grid pin(nl) to profile
+C escout(nlayer) on pressure grid p(nlayer).
+C
+      real escout(nlayer),p(nlayer)
+      real escin(nl),pin(nl),wm,wp
+      integer nl,nlayer,n1,n,nm,np
+      do n1=1,nlayer
+         if(p(n1) .gt. 3.5 .or. p(n1) .lt. 4.0e-6) then
+            escout(n1) = 0.0
+         else
+            do n = 1,nl-1
+               if (p(n1).le.pin(n).and.p(n1).ge.pin(n+1)) then
+                  nm=n
+                  np=n+1
+                  wm=abs(pin(np)-p(n1))/(pin(nm)-pin(np))
+                  wp=1.0 - wm
+               endif
+            enddo
+            escout(n1) = escin(nm)*wm + escin(np)*wp
+         endif
+      enddo
+      return
+      end
+
+c***********************************************************************
+
+      subroutine interp3(esco1,esco2,esco3,p,nlayer,
+     1     esci1,esci2,esci3,pin,nl)
+C
+C subroutine to perform 3 simultaneous linear interpolations in pressure from 
+C 1D profiles esci1-3(nl) sampled on pressure grid pin(nl) to 1D profiles 
+C esco1-3(nlayer) on pressure grid p(ngrid,nlayer).
+C
+      real esco1(nlayer),esco2(nlayer),esco3(nlayer),p(nlayer)
+      real esci1(nl),    esci2(nl),    esci3(nl),    pin(nl),wm,wp
+      integer nl,nlayer,n1,n,nm,np
+      do n1=1,nlayer
+         if (p(n1).gt. 3.5 .or. p(n1) .lt. 4.0e-6) then
+            esco1(n1)=0.0
+            esco2(n1)=0.0
+            esco3(n1)=0.0
+         else 
+            do n = 1,nl-1
+               if (p(n1).le.pin(n).and.p(n1).ge.pin(n+1)) then
+                  nm=n
+                  np=n+1
+                  wm=abs(pin(np)-p(n1))/(pin(nm)-pin(np))
+                  wp=1.0 - wm
+               endif
+            enddo
+            esco1(n1) = esci1(nm)*wm + esci1(np)*wp
+            esco2(n1) = esci2(nm)*wm + esci2(np)*wp
+            esco3(n1) = esci3(nm)*wm + esci3(np)*wp
+         endif
+      enddo
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltedata.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltedata.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nltedata.h	(revision 57)
@@ -0,0 +1,166 @@
+c INCLUDE nlte_escape.h
+       !
+       ! Escape functions and VMRs from tabulated values.
+       ! Origin: nlte_escape.dat file form Miguel L.
+       ! (Y. Wanherdrick, 09/2000)
+
+       integer     np
+       parameter ( np = 68 )                ! # data points in tabulation
+       real        pnb(np)                  ! Pressure in tabulation
+       real        ef1(np)                  ! Esc.funct.#1, tabulated
+       real        ef2(np)                  ! Esc.funct.#2, tabulated
+       real        co2vmr(np)               ! CO2 VMR tabulated
+       real        o3pvmr(np)               ! CO2 VMR tabulated
+       real        n2covmr(np)              ! N2+CO VMR tabulated
+ 
+ 
+      DATA pnb/
+     &    12.0000,    11.0000,    10.8000,
+     &    10.6000,   10.40000,   10.20000,
+     &   10.00000,    9.80000,    9.60000,
+     &    9.40000,    9.20000,    9.00000,
+     &    8.80000,    8.60000,    8.40000,
+     &    8.20000,    8.00000,    7.80000,
+     &    7.60000,    7.40000,    7.20000,
+     &    7.00000,    6.80000,    6.60000,
+     &    6.40000,    6.20000,    6.00000,
+     &    5.80000,    5.60000,    5.40000,
+     &    5.20000,    5.00000,    4.80000,
+     &    4.60000,    4.40000,    4.20000,
+     &    4.00000,    3.80000,    3.60000,
+     &    3.40000,    3.20000,    3.00000,
+     &    2.80000,    2.60000,    2.40000,
+     &    2.20000,    2.00000,    1.80000,
+     &    1.60000,    1.40000,    1.20000,
+     &    1.00000,   0.800000,   0.599999,
+     &   0.400000,   0.200000,  0.,
+     &  -0.200000,  -0.400001,  -0.600000,
+     &  -0.800000,   -1.00000,   -1.20000,
+     &   -1.40000,   -1.60000,   -1.80000,
+     &   -2.00000,   -3.00000/
+ 
+      DATA ef1/
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.58112E-04,    4.58112E-04,
+     &    4.58112E-04,    4.61707E-04,    4.76886E-04,
+     &    4.95638E-04,    5.20935E-04,    5.55511E-04,
+     &    6.01219E-04,    6.63734E-04,    7.50691E-04,
+     &    8.63474E-04,    1.00900E-03,    1.19642E-03,
+     &    1.42690E-03,    1.71398E-03,    2.06663E-03,
+     &    2.48974E-03,    3.01578E-03,    3.64350E-03,
+     &    4.40323E-03,    5.32066E-03,    6.40456E-03,
+     &    7.72069E-03,    9.25684E-03,    1.10905E-02,
+     &    1.32374E-02,    1.57643E-02,    1.87388E-02,
+     &    2.22072E-02,    2.63099E-02,    3.10614E-02,
+     &    3.66948E-02,    4.32373E-02,    5.15022E-02,
+     &    6.21455E-02,    7.77212E-02,    9.92027E-02,
+     &   0.131155,   0.179470,   0.258913,
+     &   0.380549,   0.530450,   0.643180,
+     &   0.741061,   0.826336,   0.922787,
+     &   0.997203,    1.00000/
+ 
+      DATA ef2/
+     &    1.98992E-03,    1.98992E-03,    1.98992E-03,
+     &    1.98992E-03,    1.98992E-03,    1.98992E-03,
+     &    1.98992E-03,    1.98992E-03,    1.98992E-03,
+     &    1.98992E-03,    1.98992E-03,    2.01376E-03,
+     &    2.09450E-03,    2.22993E-03,    2.42056E-03,
+     &    2.68018E-03,    3.04398E-03,    3.43896E-03,
+     &    3.80282E-03,    4.20622E-03,    4.76121E-03,
+     &    8.01698E-03,    1.19947E-02,    1.69149E-02,
+     &    2.24497E-02,    2.85244E-02,    3.54813E-02,
+     &    4.39264E-02,    5.46248E-02,    6.75367E-02,
+     &    8.29931E-02,    1.01717E-01,   0.123422,
+     &   0.148468,   0.177096,   0.208816,
+     &   0.244003,   0.282013,   0.322559,
+     &   0.365542,   0.410518,   0.457384,
+     &   0.505358,   0.553627,   0.600472,
+     &   0.644807,   0.687185,   0.727429,
+     &   0.764734,   0.798562,   0.828699,
+     &   0.854797,   0.877717,   0.897874,
+     &   0.915258,   0.929904,   0.942381,
+     &   0.952906,   0.962173,   0.970191,
+     &   0.976437,   0.981501,   0.985406,
+     &   0.988560,   0.991111,   0.993653,
+     &   0.995561,    1.00000/
+ 
+      DATA co2vmr/
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.950000,   0.950000,   0.950000,
+     &   0.949619,   0.947694,   0.945830,
+     &   0.944016,   0.940557,   0.937068,
+     &   0.932366,   0.893661/
+ 
+      DATA o3pvmr/
+     &    5.06756E-08,    9.16539E-07,    1.68217E-06,
+     &    3.00843E-06,    5.03151E-06,    8.07489E-06,
+     &    1.23137E-05,    1.79029E-05,    2.45308E-05,
+     &    3.27431E-05,    4.26692E-05,    5.44396E-05,
+     &    6.78865E-05,    8.33147E-05,    1.00148E-04,
+     &    1.18846E-04,    1.39681E-04,    1.64909E-04,
+     &    1.93617E-04,    2.25161E-04,    2.60834E-04,
+     &    3.01501E-04,    3.44953E-04,    3.91011E-04,
+     &    4.40377E-04,    4.90820E-04,    5.43200E-04,
+     &    5.95335E-04,    6.45420E-04,    6.93166E-04,
+     &    7.43729E-04,    7.93710E-04,    8.44394E-04,
+     &    8.94318E-04,    9.44732E-04,    9.94964E-04,
+     &    1.04901E-03,    1.10008E-03,    1.16302E-03,
+     &    1.22989E-03,    1.30026E-03,    1.37131E-03,
+     &    1.45556E-03,    1.55186E-03,    1.66328E-03,
+     &    1.77802E-03,    1.91546E-03,    2.07503E-03,
+     &    2.24903E-03,    2.47117E-03,    2.71728E-03,
+     &    2.99739E-03,    3.33582E-03,    3.73507E-03,
+     &    4.20819E-03,    4.76887E-03,    5.42558E-03,
+     &    6.20815E-03,    7.14473E-03,    8.28545E-03,
+     &    9.51779E-03,    1.08140E-02,    1.22359E-02,
+     &    1.36870E-02,    1.51495E-02,    1.67196E-02,
+     &    1.85485E-02,    3.36252E-02/
+ 
+      DATA n2covmr/
+     &    2.71412E-02,    2.71464E-02,    2.71490E-02,
+     &    2.71523E-02,    2.71558E-02,    2.71617E-02,
+     &    2.71672E-02,    2.71749E-02,    2.71837E-02,
+     &    2.71943E-02,    2.72058E-02,    2.72189E-02,
+     &    2.72326E-02,    2.72483E-02,    2.72661E-02,
+     &    2.72848E-02,    2.73054E-02,    2.73279E-02,
+     &    2.73514E-02,    2.73775E-02,    2.74048E-02,
+     &    2.74345E-02,    2.74672E-02,    2.75021E-02,
+     &    2.75404E-02,    2.75826E-02,    2.76340E-02,
+     &    2.77013E-02,    2.78220E-02,    2.79707E-02,
+     &    2.81759E-02,    2.84339E-02,    2.87587E-02,
+     &    2.91600E-02,    2.96561E-02,    3.02558E-02,
+     &    3.09922E-02,    3.18062E-02,    3.27010E-02,
+     &    3.35635E-02,    3.44388E-02,    3.53327E-02,
+     &    3.62143E-02,    3.70941E-02,    3.79315E-02,
+     &    3.87626E-02,    3.95524E-02,    4.03071E-02,
+     &    4.10071E-02,    4.16229E-02,    4.21231E-02,
+     &    4.25167E-02,    4.27964E-02,    4.29773E-02,
+     &    4.30488E-02,    4.29638E-02,    4.28049E-02,
+     &    4.26788E-02,    4.26822E-02,    4.29426E-02,
+     &    4.34634E-02,    4.42559E-02,    4.53038E-02,
+     &    4.65879E-02,    4.80262E-02,    4.96303E-02,
+     &    5.14885E-02,    6.91651E-02/
+ 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlteparams.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlteparams.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlteparams.h	(revision 57)
@@ -0,0 +1,18 @@
+c-----------------------------------------------------------------------
+c   INCLUDE 'nlteparams.h'
+c
+c   Parameters which govern the transition from LTE to NLTE radiation
+c   tendencies.
+c-----------------------------------------------------------------------
+
+      real ptrans           ! central pressure for transition (Pa)
+      parameter (ptrans = 0.1)
+      real zw               ! half-width for transition (scale heights)
+      parameter (zw = 0.5)
+      real pminte           ! pressure up to which LTE is calculated (Pa)
+      parameter (pminte = 0.4*ptrans)
+c     almost one scale height above transition in worst case is very safe
+      real zwi
+      parameter (zwi = 2./zw)
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlthermeq.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlthermeq.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/nlthermeq.F	(revision 57)
@@ -0,0 +1,58 @@
+      subroutine nlthermeq(ngrid, nlayer, pplev, pplay)
+c
+c  Compute the number of layers nlaylte (stored in common yomlw.h)
+c  over which local thermodynamic equilibrium
+c  radiation scheme should be run to be sure of covering at least to a
+c  height greater than (pressure lower than) p=pminte, set in nlteparams.h.
+c  The maximum layer needed is found for the worst possible case.
+c  Stephen Lewis 6/2000
+c  Modified Y. Wanherdrick/ F. Forget 09/2000
+
+      implicit none
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "nlteparams.h"
+#include "yomlw.h"
+#include "callkeys.h"
+
+c
+c     Input:
+      integer ngrid, nlayer
+      real pplev(ngrid, nlayer+1)
+      real pplay(ngrid, nlayer)
+c
+c     Local:
+      integer igpmax, ismax
+      logical firstcall
+      data firstcall /.true./
+      save firstcall, igpmax
+c
+      if(firstcall) then
+c     Find the location of maximum surface pressure.
+c     Location won't vary much so only do it at the start;
+c     with no topography location would vary, but this is only
+c     needed for an estimate so any point would do in that case.
+         igpmax = ismax(ngrid, pplev, 1)
+         write(*, 10) ptrans
+         write(*, 20) zw
+         write(*, 30) pminte
+         firstcall = .false.
+      endif
+c
+      IF(callnlte) then
+c       Find first layer above pminte at this location
+        do nlaylte = nlayer, 1, -1
+           if (pplay(igpmax, nlaylte).gt.pminte)  go to 100
+        enddo
+      ELSE
+        nlaylte=nlayer
+      END IF
+  100 write(*,*) 'LTE rad. calculations up to layer ',  nlaylte
+c
+      return
+c
+   10 format(' nlthermeq: transition to NLTE centred at ',f6.2,'Pa')
+   20 format('               half-width (scale heights) ',f6.2)
+   30 format('          suggested LTE coverage at least ',f6.2,'Pa')
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orbite.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orbite.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orbite.F	(revision 57)
@@ -0,0 +1,63 @@
+      SUBROUTINE orbite(pls,pdist_sol,pdecli)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Objet:
+c   ------
+c
+c   Distance from sun and declimation as a function of the solar
+c   longitude Ls
+c
+c   Interface:
+c   ----------
+c
+c
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   pls          Ls
+c
+c   Output:
+c   -------
+c   pdist_sol     Distance Sun-Planet in UA
+c   pdecli        declinaison ( en radians )
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c arguments:
+c ----------
+
+      REAL pday,pdist_sol,pdecli,pls,i
+
+c-----------------------------------------------------------------------
+
+c Distance Sun-Planet
+
+      pdist_sol=p_elips/(1.+e_elips*cos(pls+timeperi))
+
+c Solar declination
+
+c ********************* version before 01/01/2000 *******
+
+      pdecli= asin (sin(pls)*sin(obliquit*pi/180.))
+
+c ********************* version after 01/01/2000 *******
+c     i=obliquit*pi/180.
+c     pdecli=asin(sin(pls)*sin(i)/sqrt(sin(pls)**2+
+c    & cos(pls)**2*cos(i)**2))
+c ******************************************************
+
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orodrag.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orodrag.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orodrag.F	(revision 57)
@@ -0,0 +1,286 @@
+      SUBROUTINE ORODRAG( klon,klev 
+     I                 , KGWD, KGWDIM, KDX, KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PAPM1,PGEOM1,PTM1,PUM1
+     R                 , PVM1, PVAROR, PSIG, PGAMMA, PTHETA
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+C
+C
+C**** *ORODRAG* - 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     EXPLICIT ARGUMENTS :
+C     --------------------
+C
+C     INPUT :
+C
+C     NLON               : NUMBER OF HORIZONTAL GRID POINTS
+C     NLEV               : NUMBER OF LEVELS
+C     KGWD               : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
+C     KGWDIM             : NUMBER OF POINTS AT WHICH THE SCHEME IS CALLED
+C     KDX(NLON)          : POINTS AT WHICH TO CALL THE SCHEME
+C     KTEST(NLON)        : MAP OF CALLING POINTS
+C     PTSPHY             : LENGTH OF TIME STEP
+C     PAPHM1(NLON,NLEV+1): PRESSURE AT MIDDLE LEVELS
+C     PAPM1(NLON,NLEV)   : PRESSURE ON MODEL LEVELS
+C     PGEOM1(NLON,NLEV)  : GEOPOTENTIAL HIEGHT OF MODEL LEVELS
+C     PTM1(NLON,NLEV)    : TEMPERATURE
+C     PUM1(NLON,NLEV)    : ZONAL WIND
+C     PVM1(NLON,NLEV)    : MERIDIONAL WIND
+C     PVAROR(NLON)       : SUB-GRID SCALE STANDARD DEVIATION
+C     PSIG(NLON)         : SUB-GRID SCALE SLOPE
+C     PGAMMA(NLON)       : SUB-GRID SCALE ANISOTROPY
+C     PTHETA(NLON)       : SUB-GRID SCALE PRINCIPAL AXES ANGLE
+C
+C     OUTPUT :
+C
+C     PULOW(NLON)        : LOW LEVEL ZONAL WIND
+C     PVLOW(NLON)        : LOW LEVEL MERIDIONAL WIND
+C     PVOM(NLON,NLEV)    : ZONAL WIND TENDENCY
+C     PVOL(NLON,NLEV)    : MERIDIONAL WIND TENDENCY
+C     PTE(NLON,NLEV)     : TEMPERATURE TENDENCY
+C
+C     IMPLICIT ARGUMENTS :
+C     --------------------
+C
+C     comcstfi.h
+C     dimphys.h
+C     yoegwd.h
+C
+C     METHOD.
+C     -------
+C
+C     EXTERNALS.
+C     ----------
+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-----------------------------------------------------------------------
+      implicit none
+C
+C
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+      integer klon,klev,kidia,kfdia
+      parameter(kidia=1,kfdia=NDLO2)
+
+#include "comcstfi.h"
+#include "yoegwd.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      REAL  PTE(NDLO2,klev),
+     *      PVOL(NDLO2,klev),
+     *      PVOM(NDLO2,klev),
+     *      PULOW(NDLO2),
+     *      PVLOW(NDLO2)
+      REAL  PUM1(NDLO2,klev),
+     *      PVM1(NDLO2,klev),
+     *      PTM1(NDLO2,klev),
+     *      PVAROR(NDLO2),PSIG(NDLO2),PGAMMA(NDLO2),PTHETA(NDLO2),
+     *      PGEOM1(NDLO2,klev),
+     *      PAPM1(NDLO2,klev),
+     *      PAPHM1(NDLO2,klev+1)
+C
+      integer kgwd,kgwdim
+      real ptsphy
+      INTEGER  KDX(NDLO2),KTEST(NDLO2)
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      INTEGER  ISECT(NDLO2),
+     *         ICRIT(NDLO2),
+     *         IKCRITH(NDLO2),
+     *         IKenvh(NDLO2),
+     *         IKNU(NDLO2),
+     *         IKNU2(NDLO2),
+     *         IKCRIT(NDLO2),
+     *         IKHLIM(NDLO2)
+      integer ji,jk,jl,klevm1,ilevp1
+C      real gkwake
+      real ztmst,pvar,ztauf,zrtmst,zdelp,zb,zc,zbet
+      real zconb,zabsv,zzd1,ratio,zust,zvst,zdis,ztemp
+C
+      REAL   ZTAU(NDLO2,nlayermx+1),
+     *       ZSTAB(NDLO2,nlayermx+1),
+     *       ZVPH(NDLO2,nlayermx+1),
+     *       ZRHO(NDLO2,nlayermx+1),
+     *       ZRI(NDLO2,nlayermx+1),
+     *       ZpsI(NDLO2,nlayermx+1),
+     *       Zzdep(NDLO2,nlayermx)
+      REAL   ZDUDT(NDLO2),
+     *       ZDVDT(NDLO2),
+     *       ZDTDT(NDLO2),
+     *       ZDEDT(NDLO2),
+     *       ZVIDIS(NDLO2),
+     *       ZTFR(NDLO2),
+     *       Znu(NDLO2),
+     *       Zd1(NDLO2),
+     *       Zd2(NDLO2),
+     *       Zdmod(NDLO2)
+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
+     *     ( klon, klev , KTEST 
+     *     , IKCRIT, IKCRITH, ICRIT, ISECT, IKHLIM, ikenvh,IKNU,iknu2
+     *     , PAPHM1, PAPM1 , PUM1   , PVM1 , PTM1 , PGEOM1, pvaror
+     *     , ZRHO  , ZRI   , ZSTAB  , ZTAU , ZVPH , zpsi, zzdep
+     *     , PULOW, PVLOW 
+     *     , ptheta,pgamma,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
+     *    ( klon  , klev
+     *    , IKCRIT, ISECT, IKHLIM, KTEST, IKCRITH, ICRIT, ikenvh, IKNU
+     *    , ZRHO  , ZSTAB, ZVPH  , PVAR , pvaror,  psig
+     *    , ZTFR   , ZTAU 
+     *    , pgeom1,pgamma,zd1,zd2,zdmod,znu)
+C
+C*         4.      COMPUTE STRESS PROFILE.
+C*                 ------- ------ --------
+C
+  400 CONTINUE
+C
+C
+      CALL GWPROFIL
+     *       (  klon , klev
+     *       , kgwd   , kdx  , KTEST
+     *       , IKCRIT, IKCRITH, ICRIT  , ikenvh, IKNU
+     *       ,iknu2 , pAPHM1, ZRHO   , ZSTAB , ZTFR   , ZVPH
+     *       , ZRI   , ZTAU   , ztauf
+     *       , zdmod , znu    , psig  , pgamma , pvaror   )
+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
+CDIR$ IVDEP
+C
+C      GKWAKE=0.5
+C
+C     NOW SET IN SUGWD.F
+C
+      DO 523 JL=1,KGWD
+      JI=KDX(JL)
+      ZDELP=pAPHM1(Ji,JK+1)-pAPHM1(Ji,JK)
+      ZTEMP=-g*(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)
+      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.*pvaror(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
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/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)/cpp
+      PTE(JI,JK)=ZDTDT(JI)
+
+  523 CONTINUE
+
+  524 CONTINUE
+C
+C
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orosetup.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orosetup.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/orosetup.F	(revision 57)
@@ -0,0 +1,494 @@
+      SUBROUTINE OROSETUP
+     *         ( klon   , klev  , KTEST
+     *         , KKCRIT, KKCRITH, KCRIT, KSECT , KKHLIM
+     *         , kkenvh, kknu  , kknu2
+     *         , PAPHM1, PAPM1 , PUM1   , PVM1 , PTM1  , PGEOM1, pvaror
+     *         , PRHO  , PRI   , PSTAB  , PTAU , PVPH  ,ppsi, pzdep
+     *         , PULOW , PVLOW  
+     *         , Ptheta, pgamma,  pnu  ,  pd1  ,  pd2  ,pdmod  )
+C
+C**** *GWSETUP*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *ORODRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     F.LOTT  FOR THE NEW-GWDRAG SCHEME NOVEMBER 1993
+C
+C-----------------------------------------------------------------------
+      implicit none
+C
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+      integer klon,klev,kidia,kfdia
+
+#include "comcstfi.h"
+#include "yoegwd.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KKCRIT(NDLO2),KKCRITH(NDLO2),KCRIT(NDLO2),KSECT(NDLO2),
+     *        KKHLIM(NDLO2),KTEST(NDLO2),kkenvh(NDLO2)
+
+C
+      REAL PAPHM1(NDLO2,KLEV+1),PAPM1(NDLO2,KLEV),PUM1(NDLO2,KLEV),
+     *     PVM1(NDLO2,KLEV),PTM1(NDLO2,KLEV),PGEOM1(NDLO2,KLEV),
+     *     PRHO(NDLO2,KLEV+1),PRI(NDLO2,KLEV+1),PSTAB(NDLO2,KLEV+1),
+     *     PTAU(NDLO2,KLEV+1),PVPH(NDLO2,KLEV+1),ppsi(NDLO2,klev+1),
+     *     pzdep(NDLO2,klev)
+       REAL PULOW(NDLO2),PVLOW(NDLO2),ptheta(NDLO2),pgamma(NDLO2),
+     *     pnu(NDLO2),
+     *     pd1(NDLO2),pd2(NDLO2),pdmod(NDLO2)
+      real pvaror(NDLO2)
+C
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+C
+      LOGICAL LL1(NDLO2,nlayermx+1)
+      integer kknu(NDLO2),kknu2(NDLO2),kknub(NDLO2),kknul(NDLO2),
+     *        kentp(NDLO2),ncount(NDLO2)  
+C
+      REAL ZHCRIT(NDLO2,nlayermx),ZNCRIT(NDLO2,nlayermx),
+     *     ZVPF(NDLO2,nlayermx), ZDP(NDLO2,nlayermx)
+      REAL ZNORM(NDLO2),zpsi(NDLO2),zb(NDLO2),zc(NDLO2),
+     *      zulow(NDLO2),zvlow(NDLO2),znup(NDLO2),znum(NDLO2)
+C
+c   declarations pour "implicit none"
+      integer jk,jl,ilevm1,ilevm2,ilevh
+      real zu,zphi,zcons1,zcons2,zcons3,zwind,zdwind,zhgeo
+      real zvt1,zvt2,zst,zvar,zdelp,zstabm,zstabp,zrhom,zrhop
+      real alpha,zggeenv,zggeom1,zgvar
+      logical lo
+
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c     print *,' entree gwsetup'
+ 100  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         1.1   COMPUTATIONAL CONSTANTS
+C                -----------------------
+C
+
+      kidia=1
+	  kfdia=klon
+
+ 110  CONTINUE
+C
+      ILEVM1=KLEV-1
+      ILEVM2=KLEV-2
+      ILEVH =KLEV/3
+C
+      ZCONS1=1./r
+cold  ZCONS2=G**2/CPD
+      ZCONS2=g**2/cpp
+cold  ZCONS3=1.5*API
+      ZCONS3=1.5*PI
+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*      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)=4.*pvaror(JL)
+      ZHGEO=PGEOM1(JL,JK)/g
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).NEQV.ll1(JL,JK+1)) THEN
+        kknu(JL)=JK
+      ENDIF
+ 2003 CONTINUE
+ 2002 CONTINUE
+      DO 2004 JK=KLEV,ilevh,-1
+      DO 2005 JL=kidia,kfdia
+      ZHCRIT(JL,JK)=3.*pvaror(JL)
+      ZHGEO=PGEOM1(JL,JK)/g
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).NEQV.ll1(JL,JK+1)) THEN
+        kknu2(JL)=JK
+      ENDIF
+ 2005 CONTINUE
+ 2004 CONTINUE
+      DO 2006 JK=KLEV,ilevh,-1
+      DO 2007 JL=kidia,kfdia
+      ZHCRIT(JL,JK)=2.*pvaror(JL)
+      ZHGEO=PGEOM1(JL,JK)/g
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).NEQV.ll1(JL,JK+1)) THEN
+        kknub(JL)=JK
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+      DO 2008 JK=KLEV,ilevh,-1
+      DO 2009 JL=kidia,kfdia
+      ZHCRIT(JL,JK)=pvaror(JL)
+      ZHGEO=PGEOM1(JL,JK)/g
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).NEQV.ll1(JL,JK+1)) THEN
+        kknul(JL)=JK
+      ENDIF
+ 2009 CONTINUE
+ 2008 CONTINUE
+C
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      if(kknub(jl).eq.nktopg) kknul(jl)=klev
+C
+C     CHANGE IN HERE TO STOP KKNUL=KKNUB
+C
+      if(kknul(jl).le.kknub(jl)) kknul(jl)=nktopg
+ 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.-cpp*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)*pi/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.-cpp*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
+C*****************************************************************************
+C
+C     O.K. THERE IS A POSSIBLE PROBLEM HERE. IF KKNUL=KKNUB THEN
+C     DIVISION BY ZERO OCCURS. I HAVE PUT A FIX IN HERE BUT WILL ASK FRANCOIS 
+C     LOTT ABOUT IT IN PARIS.
+C
+C     MAT COLLINS 30.1.96
+C
+C     ALSO IF THIS IS THE CASE PSTAB AND PRHO ARE NOT DEFINED AT KLEV+1
+C     SO I HAVE ADDED THE ELSE
+C
+C*****************************************************************************
+      IF (KKNUL(JL).NE.KKNUB(JL)) THEN
+        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)))
+      ELSE
+      WRITE(*,*) 'OROSETUP: KKNUB=KKNUL= ',KKNUB(JL),' AT JL= ',JL
+        PSTAB(JL,KLEV+1)=PSTAB(JL,KLEV)
+        PRHO(JL,KLEV+1)=PRHO(JL,KLEV)
+      ENDIF
+        ZVAR=PVARor(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)
+     *          /(g*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.KKNU2(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/g)*
+     *            ((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
+        
+      IF (JK.LT.KKENVH(JL)) 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/g)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/ZWIND     
+            IF((ZNUM(JL).LE.1.5).AND.(ZNUP(JL).GT.1.5)
+     *                          .AND.(KKCRITH(JL).EQ.KLEV))
+     *      KKCRITH(JL)=JK
+     
+      ENDIF
+      
+      ENDIF
+      
+ 236  CONTINUE
+ 
+      DO 237 JL=KIDIA,KFDIA
+      KKCRITH(JL)=MIN0(KKCRITH(JL),KKNU(JL))
+ 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)*pi/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(pvaror(jl)*g,1.)     
+        pzdep(jl,jk)=SQRT((zggeenv-zggeom1)/(zggeom1+zgvar))      
+      end if
+ 253  CONTINUE
+ 254  CONTINUE
+
+ 260  CONTINUE
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/phyetat0.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/phyetat0.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/phyetat0.F	(revision 57)
@@ -0,0 +1,527 @@
+      SUBROUTINE phyetat0 (fichnom,tab0,Lmodif,nsoil,nq,
+     .           day_ini,time,
+     .           tsurf,tsoil,emis,q2,qsurf,co2ice)
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c  Adaptation à Mars : Yann Wanherdrick 
+c Objet: Lecture de l etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "netcdf.inc"
+#include "dimphys.h"
+#include "comgeomfi.h"
+#include "surfdat.h"
+#include "planete.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+#include "comcstfi.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+      INTEGER nbsrf !Mars nbsrf a 1 au lieu de 4
+      PARAMETER (nbsrf=1) ! nombre de sous-fractions pour une maille
+
+      INTEGER radpas
+      REAL co2_ppm
+      REAL solaire,time
+      REAL tsoil(ngridmx,nsoil,nbsrf)
+
+      REAL xmin, xmax
+c
+      INTEGER nsoil,nq
+      INTEGER ig,iq,lmax
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil 
+      INTEGER length
+      PARAMETER (length=100)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+      CHARACTER*1 yes
+c
+      integer   Lmodif,tab0
+      REAL      p_rad,p_omeg,p_g,p_mugaz,p_daysec
+      REAL tsurf(ngridmx,nbsrf),co2ice(ngridmx),emis(ngridmx)
+      REAL q2(ngridmx, llm+1)
+      REAL qsurf(ngridmx,nq) 
+      INTEGER day_ini,nqold
+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
+        CALL ABORT
+      ENDIF
+
+
+c modifications possibles des variables de tab_cntrl
+      PRINT*
+      write(*,*) 'TABFI de phyeta0',Lmodif,tab0
+      call tabfi (nid,Lmodif,tab0,day_ini,lmax,p_rad,
+     .              p_omeg,p_g,p_mugaz,p_daysec,time)
+c
+c Lecture des latitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "latitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <latitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, lati)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, lati)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <latitude>'
+         CALL abort
+      ENDIF
+c
+c Lecture des longitudes (coordonnees):
+c
+      ierr = NF_INQ_VARID (nid, "longitude", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <longitude> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, long)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, long)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <longitude>'
+         CALL abort
+      ENDIF
+c
+c Lecture des aires des mailles:
+c
+      ierr = NF_INQ_VARID (nid, "area", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <area> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, area)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, area)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <area>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(area)
+      xmax = MAXVAL(area)
+      PRINT*,'Aires des mailles <area>:', xmin, xmax
+c
+c Lecture du geopotentiel au sol:
+c
+      ierr = NF_INQ_VARID (nid, "phisfi", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <phisfi> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisfi)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, phisfi)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <phisfi>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(phisfi)
+      xmax = MAXVAL(phisfi)
+      PRINT*,'Geopotentiel au sol <phisfi>:', xmin, xmax
+c
+c Lecture de l''albedo du sol nu:
+c
+      ierr = NF_INQ_VARID (nid, "albedodat", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <albedodat> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albedodat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, albedodat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <albedodat>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(albedodat)
+      xmax = MAXVAL(albedodat)
+      PRINT*,'Albedo du sol nu <albedodat>:', xmin, xmax
+c
+c Lecture de l''inertie thermique du sol:
+c
+      ierr = NF_INQ_VARID (nid, "inertiedat", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <inertiedat> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, inertiedat)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, inertiedat)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <inertiedat>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(inertiedat)
+      xmax = MAXVAL(inertiedat)
+      PRINT*,'Inertie thermique du sol <inertiedat>:', xmin, xmax
+c
+c ZMEA
+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, ngridmx
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'<zmea>:', xmin, xmax
+c
+c ZSTD
+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, ngridmx
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'<zstd>:', xmin, xmax
+c
+c ZSIG
+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, ngridmx
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'<zsig>:', xmin, xmax
+c
+c ZGAM
+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, ngridmx
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'<zgam>:', xmin, xmax
+c
+c ZTHE
+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, ngridmx
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'<zthe>:', xmin, xmax
+c
+c CO2 ice cover
+c
+      ierr = NF_INQ_VARID (nid, "co2ice", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <co2ice> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, co2ice)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, co2ice)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <co2ice>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(co2ice)
+      xmax = MAXVAL(co2ice)
+      PRINT*,'CO2 ice cover <co2ice>:', xmin, xmax
+c
+c Lecture des temperatures du sol:
+c
+      ierr = NF_INQ_VARID (nid, "tsurf", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <tsurf> est absent'
+         PRINT*, '          Mais je vais essayer de lire TS**'
+         IF (nbsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+         ENDIF
+         DO nsrf = 1, nbsrf
+           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, tsurf(1,nsrf))
+#else
+           ierr = NF_GET_VAR_REAL(nid, nvarid, tsurf(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
+           xmin = MINVAL(tsurf)
+           xmax = MAXVAL(tsurf)
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <tsurf> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsurf(1,1))
+#else
+         ierr = NF_GET_VAR_REAL(nid, nvarid, tsurf(1,1))
+#endif
+         IF (ierr.NE.NF_NOERR) THEN
+            PRINT*, "phyetat0: Lecture echouee pour <TSURF>"
+            CALL abort
+         ENDIF
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         xmin = MINVAL(tsurf)
+         xmax = MAXVAL(tsurf)
+         PRINT*,'Temperature du sol <tsurf>', xmin, xmax
+         IF (nbsrf >= 2) THEN
+            DO nsrf = 2, nbsrf
+               DO i = 1, ngridmx
+                  tsurf(i,nsrf) = tsurf(i,1)
+               ENDDO
+            ENDDO
+         ENDIF
+      ENDIF
+c
+c Lecture des temperatures du sol profond:
+c
+      IF (nsoil.GT.99 .OR. nbsrf.GT.99) THEN
+         PRINT*, "Trop de couches ou sous-mailles"
+         CALL abort
+      ENDIF
+      DO nsrf = 1, nbsrf
+         DO isoil=1, nsoil
+            WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+            ierr = NF_INQ_VARID (nid, 'tsoil', nvarid)
+            IF (ierr.NE.NF_NOERR) THEN
+               PRINT*, "phyetat0: Le champ <tsoil> est absent"
+               PRINT*, "          Il prend donc la valeur de surface"
+               DO i=1, ngridmx
+                  tsoil(i,isoil,nsrf)=tsurf(i,nsrf)
+               ENDDO
+            ELSE
+#ifdef NC_DOUBLE
+              ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,1,nsrf))
+#else
+              ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,1,nsrf))
+#endif
+               IF (ierr.NE.NF_NOERR) THEN
+                  PRINT*, "Lecture echouee pour <tsoil>"
+                  CALL abort
+               ENDIF
+            ENDIF
+         ENDDO
+      ENDDO
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(tsoil)
+      xmax = MAXVAL(tsoil)
+      PRINT*,'Temperatures du sol profond <tsoil>', xmin, xmax
+c
+c Surface emissivity
+c
+      ierr = NF_INQ_VARID (nid, "emis", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <emis> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, emis)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, emis)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <emis>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(emis)
+      xmax = MAXVAL(emis)
+      PRINT*,'Surface emissivity <emis>:', xmin, xmax
+c
+c pbl wind variance
+c
+      ierr = NF_INQ_VARID (nid, "q2", nvarid)
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Le champ <q2> est absent'
+         CALL abort
+      ENDIF
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q2)
+#else
+      ierr = NF_GET_VAR_REAL(nid, nvarid, q2)
+#endif
+      IF (ierr.NE.NF_NOERR) THEN
+         PRINT*, 'phyetat0: Lecture echouee pour <q2>'
+         CALL abort
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINVAL(q2)
+      xmax = MAXVAL(q2)
+      PRINT*,'pbl wind variance <q2>:', xmin, xmax
+c
+c tracer on surface
+c
+
+      IF(nq.GE.1) THEN
+         nqold=nq
+         DO iq=1,nq
+            str7(1:5)='qsurf'
+            WRITE(str7(6:7),'(i2.2)') iq
+            ierr = NF_INQ_VARID (nid,str7,nvarid)
+            IF (ierr.NE.NF_NOERR) THEN
+                write (*,*) ' WARNING : ',str7,' not in the file'
+                write (*,*) str7, ' set to 0'
+                do ig=1,ngridmx
+                    qsurf(ig,iq)=0.
+                end do
+                nqold=min(iq-1,nqold)
+            ELSE
+#ifdef NC_DOUBLE
+              ierr = NF_GET_VAR_DOUBLE(nid, nvarid,qsurf(1,iq))
+#else
+              ierr = NF_GET_VAR_REAL(nid, nvarid,qsurf(1,iq))
+#endif
+              IF (ierr.NE.NF_NOERR) THEN
+                PRINT*, 'phyetat0: Lecture echouee pour <',str7,'>'
+                CALL abort
+              ENDIF
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           xmin = MINVAL(qsurf(1:ngridmx,iq))
+           xmax = MAXVAL(qsurf(1:ngridmx,iq))
+      PRINT*,'tracer on surface <',str7,'>:', xmin, xmax
+         ENDDO
+         if(nqold.lt.nq) then
+c        case when new tracer are added in addition to old ones
+             write(*,*)'qsurf 1 to ', nqold,'were already present'
+             write(*,*)'qsurf ', nqold+1,' to ', nqmx,'are new'
+            yes=' '
+            do while ((yes.ne.'y').and.(yes.ne.'n'))
+             write(*,*) 'Would you like to reindex qsurf # 1 ->',nqold
+             write(*,*) 'to #',nqmx-nqold+1,'->', nqmx,'   (y or n) ?'
+             read(*,fmt='(a)') yes
+            end do
+            if (yes.eq.'y') then
+              write(*,*) 'OK, let s reindex qsurf'
+                 do ig=1,ngridmx
+                    do iq=nqmx,nqmx-nqold+1,-1
+                       qsurf(ig,iq)=qsurf(ig,iq-nqmx+nqold)
+                    end do
+                    do iq=nqmx-nqold,1,-1
+                       qsurf(ig,iq)= 0.
+                    end do
+                 end do
+            end if
+         end if
+      ENDIF
+c
+c Fermer le fichier:
+c
+      ierr = NF_CLOSE(nid)
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physdem1.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physdem1.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physdem1.F	(revision 57)
@@ -0,0 +1,450 @@
+      subroutine physdem1(filename,lonfi,latfi,nsoil,nq,
+     .                   phystep,day_ini,
+     .                   time,tsurf,tsoil,co2ice,emis,q2,qsurf,
+     .                   airefi,alb,ith,pzmea,pzstd,pzsig,pzgam,pzthe)
+
+      IMPLICIT none
+c-------------------------------------------------------------
+C Author : L. Fairhead
+C Date   : 01/10/1999
+C Objet  : Ecriture des etats initiaux physiques
+c-------------------------------------------------------------
+c
+c
+c
+c
+c
+#include "dimensions.h"
+#include "paramet.h"
+c-----------------------------------------------------------------------
+#include "comvert.h"
+#include "comgeom2.h"
+#include "control.h"
+#include "comdissnew.h"
+#include "logic.h"
+#include "ener.h"
+#include "netcdf.inc"
+#include "dimphys.h"
+c
+      INTEGER nid,iq
+      INTEGER, parameter :: ivap=1
+      REAL, parameter :: qsolmax= 150.0
+      character (len=*) :: filename
+      character (len=7) :: str7
+
+      REAL day_ini
+      INTEGER nsoil,nq
+      integer ierr,idim1,idim2,idim3,idim4,idim5,nvarid
+
+c
+      REAL phystep,time
+      REAL latfi(ngridmx), lonfi(ngridmx)
+      REAL champhys(ngridmx)
+      REAL tsurf(ngridmx)
+      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"
+#include "comgeomfi.h"
+#include "surfdat.h"
+#include "planete.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+#include "comcstfi.h"
+
+      real co2ice(ngridmx),tsoil(ngridmx,nsoil),emis(ngridmx)
+      real q2(ngridmx, llm+1),qsurf(ngridmx,nq)
+      real airefi(ngridmx)
+      real alb(ngridmx),ith(ngridmx)
+      real pzmea(ngridmx),pzstd(ngridmx)
+      real pzsig(ngridmx),pzgam(ngridmx),pzthe(ngridmx)
+      integer ig
+      INTEGER lnblnk
+      EXTERNAL lnblnk
+
+c-----------------------------------------------------------------------
+
+      CALL SCOPY(ngridmx,airefi,1,area,1)
+      DO ig=1,ngridmx
+         albedodat(ig)=alb(ig)
+         inertiedat(ig)=ith(ig)
+         zmea(ig)=pzmea(ig)
+         zstd(ig)=pzstd(ig)
+         zsig(ig)=pzsig(ig)
+         zgam(ig)=pzgam(ig)
+         zthe(ig)=pzthe(ig)
+      ENDDO
+c
+c  stockage sur le fichier Physique:
+c
+      ierr = NF_CREATE(trim((filename)),NF_CLOBBER, nid)
+      IF (ierr.NE.NF_NOERR) THEN
+        WRITE(6,*)' Problem creating restartfi.nc'
+        WRITE(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+c
+      ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 26,
+     .                       "Fichier demarrage physique")
+c
+      ierr = NF_DEF_DIM (nid,"index",length,idim1)
+      ierr = NF_DEF_DIM (nid,"physical_points",ngridmx,idim2)
+      ierr = NF_DEF_DIM (nid,"subsurface_layers",nsoil,idim3)
+      ierr = NF_DEF_DIM (nid,"nlayer+1",llm+1,idim4)
+      ierr = NF_DEF_DIM (nid,"number_of_advected_fields",nq,idim5)
+c
+      ierr = NF_ENDDEF(nid)
+c
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+
+      write(*,*) "ngridmx: ",ngridmx
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c pour la DOCUMENTATION    (fichier io/maj/fi_cntl)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c Info sur la grille physique
+      tab_cntrl(1) = float(ngridmx)  ! nombre de points de la grille physique
+      tab_cntrl(2) = float(nlayermx) ! nombre de couches
+      tab_cntrl(3) = day_ini + int(time)         ! jour initial
+      tab_cntrl(4) = time -int(time)            ! heure initiale 0
+
+c Info sur la Planete Mars pour la dynamique et la physique
+      tab_cntrl(5) = rad      ! rayon de mars(m) ~3397200
+      tab_cntrl(6) = omeg     ! vitesse de rotation (rad.s-1)
+      tab_cntrl(7) = g        ! gravite (m.s-2) ~3.72
+      tab_cntrl(8) = mugaz    ! Masse molaire de l''atm (g.mol-1) ~43.49
+      tab_cntrl(9) = rcp      !  = r/cp  ~0.256793 (=kappa dans dynamique)
+      tab_cntrl(10) = daysec  ! duree du sol (s)  ~88775
+
+      tab_cntrl(11) = phystep  ! pas de temps de la physique 
+      tab_cntrl(12) = 0.
+      tab_cntrl(13) = 0.
+
+c Info sur la Planete Mars pour la physique uniquement
+      tab_cntrl(14) = year_day  ! duree de l''annee (sols) ~668.6
+      tab_cntrl(15) = periheli  ! dist.min. soleil-mars (Mkm) ~206.66
+      tab_cntrl(16) = aphelie   ! dist.max. soleil-mars (Mkm) ~249.22
+      tab_cntrl(17) = peri_day  ! date du perihelie (sols depuis printemps)
+      tab_cntrl(18) = obliquit  ! Obliquite de la planete (deg) ~23.98
+
+c Couche limite et Turbulence
+      tab_cntrl(19) = z0        ! surface roughness (m) ~0.01
+      tab_cntrl(20) = lmixmin   ! longueur de melange ~100
+      tab_cntrl(21) = emin_turb ! energie minimale ~1.e-8
+
+c propriete optiques des calottes et emissivite du sol
+      tab_cntrl(22) = albedice(1)  ! Albedo calotte nord ~0.5
+      tab_cntrl(23) = albedice(2)  ! Albedo calotte sud ~0.5
+      tab_cntrl(24) = emisice(1)   ! Emissivite calotte nord ~0.95
+      tab_cntrl(25) = emisice(2)   ! Emissivite calotte sud ~0.95
+      tab_cntrl(26) = emissiv      ! Emissivite du sol martien ~.95
+      tab_cntrl(31) = iceradius(1) ! mean scat radius of CO2 snow (north)
+      tab_cntrl(32) = iceradius(2) ! mean scat radius of CO2 snow (south)
+      tab_cntrl(33) = dtemisice(1) ! time scale for snow metamorphism (north)
+      tab_cntrl(34) = dtemisice(2) ! time scale for snow metamorphism (south)
+
+c Proprietes des poussiere aerosol
+      tab_cntrl(27) = tauvis      ! profondeur optique visible moyenne
+
+      tab_cntrl(28) = 0. 
+      tab_cntrl(29) = 0.
+      tab_cntrl(30) = 0.
+
+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, "area", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "area", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 16,
+     .                        "Aire des mailles")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,area)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,area)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "phisfi", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "phisfi", NF_FLOAT, 1, idim2,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,phisfi)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,phisfi)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "albedodat", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "albedodat", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 16,
+     .                        "Albedo du sol nu")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedodat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,albedodat)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "inertiedat", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "inertiedat", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 24,
+     .                        "Inertie thermique du sol")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,inertiedat)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,inertiedat)
+#endif
+c
+c   fichier pour les programmes de Francois Lott
+
+      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_PUT_ATT_TEXT (nid, nvarid, "title", 12,
+     .                        "Relief moyen")
+      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_PUT_ATT_TEXT (nid, nvarid, "title", 18,
+     .                        "Ecartype du relief")
+      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_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                        "Relief: parametre sigma")
+      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_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                        "Relief: parametre gamma")
+      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_PUT_ATT_TEXT (nid, nvarid, "title", 23,
+     .                        "Relief: parametre theta")
+      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 Ecriture des champs physiques
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "co2ice", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "co2ice", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 13,
+     .                        "CO2 ice cover")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,co2ice)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,co2ice)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "tsurf", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "tsurf", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19,
+     .                        "Surface temperature")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsurf)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tsurf)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"tsoil",NF_DOUBLE,2,(/idim2,idim3/),nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"tsoil",NF_FLOAT,2,(/idim2,idim3/),nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 16,
+     .                        "Soil temperature")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "emis", NF_DOUBLE, 1, idim2,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "emis", NF_FLOAT, 1, idim2,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 18,
+     .                        "Surface emissivity")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,emis)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,emis)
+#endif
+c
+      ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid, "q2", NF_DOUBLE, 2, (/idim2,idim4/),nvarid)
+#else
+      ierr = NF_DEF_VAR (nid, "q2", NF_FLOAT, 2,(/idim2,idim4/),nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 17,
+     .                        "pbl wind variance")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q2)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,q2)
+#endif
+c
+      IF(nq.GE.1) THEN
+         DO iq=1,nq
+            str7(1:5)='qsurf'
+            WRITE(str7(6:7),'(i2.2)') iq
+            ierr = NF_REDEF (nid)
+#ifdef NC_DOUBLE
+            ierr = NF_DEF_VAR (nid,str7,NF_DOUBLE,1,idim2,nvarid)
+#else
+            ierr = NF_DEF_VAR (nid,str7,NF_FLOAT,1,idim2,nvarid)
+#endif
+            ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 17,
+     .                        "tracer on surface")
+            ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+            ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsurf(1,iq))
+#else
+            ierr = NF_PUT_VAR_REAL (nid,nvarid,qsurf(1,iq))
+#endif
+         ENDDO
+      ENDIF
+c
+      ierr = NF_CLOSE(nid)
+
+      RETURN
+
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physiq.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physiq.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/physiq.F	(revision 57)
@@ -0,0 +1,1351 @@
+      SUBROUTINE physiq(ngrid,nlayer,nq,
+     $            firstcall,lastcall,
+     $            pday,ptime,ptimestep,
+     $            pplev,pplay,pphi,
+     $            pu,pv,pt,pq,
+     $            pw,
+     $            pdu,pdv,pdt,pdq,pdpsrf,tracerdyn)
+
+
+      IMPLICIT NONE
+c=======================================================================
+c
+c   subject:
+c   --------
+c
+c   Organisation of the physical parametrisations of the LMD 
+c   martian atmospheric general circulation model.
+c
+c   The GCM can be run without or with tracer transport
+c   depending on the value of Logical "tracer" in file  "callphys.def"
+c   Tracers may be water vapor, ice OR chemical species OR dust particles
+c
+c   SEE comments in initracer.F about numbering of tracer species...
+c
+c   It includes:
+c
+c      1. Initialization:
+c      1.1 First call initializations
+c      1.2 Initialization for every call to physiq
+c      1.2.5 Compute mean mass and cp, R and thermal conduction coeff.
+c      2. Compute radiative transfer tendencies
+c         (longwave and shortwave) for CO2 and dust.
+c      3. Gravity wave and subgrid scale topography drag :
+c      4. Vertical diffusion (turbulent mixing):
+c      5. Convective adjustment
+c      6. Condensation and sublimation of carbon dioxide.
+c      7.  TRACERS :
+c       7a. water and water ice
+c       7b. call for photochemistry when tracers are chemical species
+c       7c. other scheme for tracer (dust) transport (lifting, sedimentation)
+c       7d. updates (CO2 pressure variations, surface budget)
+c      8. Contribution to tendencies due to thermosphere
+c      9. Surface and sub-surface temperature calculations
+c     10. Write outputs :
+c           - "startfi", "histfi" (if it's time)
+c           - Saving statistics (if "callstats = .true.")
+c           - Dumping eof (if "calleofdump = .true.")
+c           - Output any needed variables in "diagfi" 
+c      10. Diagnostic: mass conservation of tracers
+c 
+c   author: 
+c   ------- 
+c           Frederic Hourdin	15/10/93
+c           Francois Forget		1994
+c           Christophe Hourdin	02/1997 
+c           Subroutine completly rewritten by F.Forget (01/2000)
+c           Introduction of the photochemical module: S. Lebonnois (11/2002)
+c           Introduction of the thermosphere module: M. Angelats i Coll (2002)
+c           Water ice clouds: Franck Montmessin (update 06/2003)
+c           
+c
+c
+c   arguments:
+c   ----------
+c
+c   input:
+c   ------
+c    ecri                  period (in dynamical timestep) to write output
+c    ngrid                 Size of the horizontal grid.
+c                          All internal loops are performed on that grid.
+c    nlayer                Number of vertical layers.
+c    nq                    Number of advected fields
+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    ptime                 Universal time (0<ptime<1): ptime=0.5 at 12:00 UT
+c    ptimestep             timestep (s)
+c    pplay(ngrid,nlayer)   Pressure at the middle of the layers (Pa)
+c    pplev(ngrid,nlayer+1) intermediate pressure levels (pa)
+c    pphi(ngrid,nlayer)    Geopotential at the middle of the layers (m2s-2)
+c    pu(ngrid,nlayer)      u component of the wind (ms-1)
+c    pv(ngrid,nlayer)      v component of the wind (ms-1)
+c    pt(ngrid,nlayer)      Temperature (K)
+c    pq(ngrid,nlayer,nq)   Advected fields
+c    pudyn(ngrid,nlayer)    \ 
+c    pvdyn(ngrid,nlayer)     \ Dynamical temporal derivative for the
+c    ptdyn(ngrid,nlayer)     / corresponding variables
+c    pqdyn(ngrid,nlayer,nq) /
+c    pw(ngrid,?)           vertical velocity
+c
+c   output:
+c   -------
+c
+c    pdu(ngrid,nlayermx)        \
+c    pdv(ngrid,nlayermx)         \  Temporal derivative of the corresponding
+c    pdt(ngrid,nlayermx)         /  variables due to physical processes.
+c    pdq(ngrid,nlayermx)        /
+c    pdpsrf(ngrid)             /
+c    tracerdyn                 call tracer in dynamical part of GCM ?
+
+c
+c=======================================================================
+c
+c    0.  Declarations :
+c    ------------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comgeomfi.h"
+#include "surfdat.h"
+#include "comdiurn.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "planete.h"
+#include "comsaison.h"
+#include "control.h"
+#include "dimradmars.h"
+#include "comg1d.h"
+#include "tracer.h"
+#include "nlteparams.h"
+
+#include "chimiedata.h"
+#include "watercap.h"
+#include "fisice.h"
+#include "param.h"
+#include "param_v3.h"
+#include "conc.h"
+
+#include "netcdf.inc"
+
+
+
+c Arguments :
+c -----------
+
+c   inputs:
+c   -------
+      INTEGER ngrid,nlayer,nq
+      REAL ptimestep
+      REAL pplev(ngridmx,nlayer+1),pplay(ngridmx,nlayer)
+      REAL pphi(ngridmx,nlayer)
+      REAL pu(ngridmx,nlayer),pv(ngridmx,nlayer)
+      REAL pt(ngridmx,nlayer),pq(ngridmx,nlayer,nq)
+      REAL pw(ngridmx,nlayer) !Mars pvervel transmit par dyn3d
+      REAL zh(ngridmx,nlayermx)      ! potential temperature (K)
+      LOGICAL firstcall,lastcall
+
+      REAL pday
+      REAL ptime 
+      logical tracerdyn
+
+c   outputs:
+c   --------
+c     physical tendencies
+      REAL pdu(ngridmx,nlayer),pdv(ngridmx,nlayer)
+      REAL pdt(ngridmx,nlayer),pdq(ngridmx,nlayer,nq)
+      REAL pdpsrf(ngridmx) ! surface pressure tendency
+
+
+c Local saved variables:
+c ----------------------
+c     aerosol (dust or ice) extinction optical depth  at reference wavelength 
+c     "longrefvis" set in dimradmars.h , for one of the "naerkind"  kind of
+c      aerosol optical properties  :
+      REAL aerosol(ngridmx,nlayermx,naerkind) 
+
+      INTEGER day_ini  ! Initial date of the run (sol since Ls=0) 
+      INTEGER icount     ! counter of calls to physiq during the run.
+      REAL tsurf(ngridmx)            ! Surface temperature (K)
+      REAL tsoil(ngridmx,nsoilmx)    ! sub-surface temperatures (K)
+      REAL co2ice(ngridmx)           ! co2 ice surface layer (kg.m-2)  
+      REAL albedo(ngridmx,2)         ! Surface albedo in each solar band
+      REAL emis(ngridmx)             ! Thermal IR surface emissivity
+      REAL dtrad(ngridmx,nlayermx)   ! Net atm. radiative heating rate (K.s-1)
+      REAL fluxrad_sky(ngridmx)      ! rad. flux from sky absorbed by surface (W.m-2)
+      REAL fluxrad(ngridmx)          ! Net radiative surface flux (W.m-2)
+      REAL capcal(ngridmx)           ! surface heat capacity (J m-2 K-1)
+      REAL fluxgrd(ngridmx)          ! surface conduction flux (W.m-2)
+      REAL qsurf(ngridmx,nqmx)       ! tracer on surface (e.g. kg.m-2)
+      REAL q2(ngridmx,nlayermx+1)    ! Turbulent Kinetic Energy 
+      INTEGER ig_vl1                 ! Grid Point near VL1   (for diagnostic) 
+
+      SAVE day_ini, icount
+      SAVE aerosol, tsurf,tsoil
+      SAVE co2ice,albedo,emis, q2
+      SAVE capcal,fluxgrd,dtrad,fluxrad,fluxrad_sky,qsurf
+      SAVE ig_vl1
+
+      REAL stephan   
+      DATA stephan/5.67e-08/  ! Stephan Boltzman constant
+      SAVE stephan
+
+c Local variables :
+c -----------------
+
+
+      CHARACTER*80 fichier 
+      INTEGER l,ig,ierr,igout,iq, tapphys
+      INTEGER iqmin                     ! Used if iceparty engaged
+
+      REAL fluxsurf_lw(ngridmx)      !incident LW (IR) surface flux (W.m-2)
+      REAL fluxsurf_sw(ngridmx,2)    !incident SW (solar) surface flux (W.m-2)
+      REAL fluxtop_lw(ngridmx)       !Outgoing LW (IR) flux to space (W.m-2)
+      REAL fluxtop_sw(ngridmx,2)     !Outgoing SW (solar) flux to space (W.m-2)
+c     for clear area (uncovered by clouds) :
+      REAL clsurf_lw(ngridmx)      !incident LW (IR) surface flux (W.m-2) 
+      REAL clsurf_sw(ngridmx,2)    !incident SW (solar) surface flux (W.m-2)
+      REAL cltop_lw(ngridmx)       !Outgoing LW (IR) flux to space (W.m-2)
+      REAL cltop_sw(ngridmx,2)     !Outgoing SW (solar) flux to space (W.m-2)
+      REAL tauref(ngridmx)           ! Reference column optical depth at 700 Pa
+                                     ! (used if active=F) 
+      REAL tau(ngridmx,naerkind)     ! Column dust optical depth at each point
+      REAL zls                       !  solar longitude (rad)
+      REAL zday                      ! date (time since Ls=0, in martian days)
+      REAL zzlay(ngridmx,nlayermx)   ! altitude at the middle of the layers
+      REAL zzlev(ngridmx,nlayermx+1) ! altitude at layer boundaries
+      REAL latvl1,lonvl1             ! Viking Lander 1 point (for diagnostic)
+
+
+c     Tendancies due to various processes:
+      REAL dqsurf(ngridmx,nqmx)
+      REAL zdtlw(ngridmx,nlayermx)     ! (K/s)
+      REAL zdtsw(ngridmx,nlayermx)     ! (K/s)
+      REAL cldtlw(ngridmx,nlayermx)     ! (K/s) LW heating rate for clear area
+      REAL cldtsw(ngridmx,nlayermx)     ! (K/s) SW heating rate for clear area
+      REAL zdtnirco2(ngridmx,nlayermx) ! (K/s)
+      REAL zdtnlte(ngridmx,nlayermx)   ! (K/s)
+      REAL zdtsurf(ngridmx)            ! (K/s)
+      REAL zdtcloud(ngridmx,nlayermx)
+      REAL zdvdif(ngridmx,nlayermx),zdudif(ngridmx,nlayermx)  ! (m.s-2)
+      REAL zdhdif(ngridmx,nlayermx), zdtsdif(ngridmx)         ! (K/s)
+      REAL zdvadj(ngridmx,nlayermx),zduadj(ngridmx,nlayermx)  ! (m.s-2)
+      REAL zdhadj(ngridmx,nlayermx)                           ! (K/s)
+      REAL zdtgw(ngridmx,nlayermx)                            ! (K/s)
+      REAL zdugw(ngridmx,nlayermx),zdvgw(ngridmx,nlayermx)    ! (m.s-2)
+      REAL zdtc(ngridmx,nlayermx),zdtsurfc(ngridmx)
+      REAL zdvc(ngridmx,nlayermx),zduc(ngridmx,nlayermx)
+
+      REAL zdqdif(ngridmx,nlayermx,nqmx), zdqsdif(ngridmx,nqmx)
+      REAL zdqsed(ngridmx,nlayermx,nqmx), zdqssed(ngridmx,nqmx)
+      REAL zdqdev(ngridmx,nlayermx,nqmx), zdqsdev(ngridmx,nqmx)
+      REAL zdqadj(ngridmx,nlayermx,nqmx)
+      REAL zdqc(ngridmx,nlayermx,nqmx)
+      REAL zdqcloud(ngridmx,nlayermx,nqmx)
+      REAL zdqscloud(ngridmx,nqmx)
+      REAL zdqchim(ngridmx,nlayermx,nqmx)
+      REAL zdqschim(ngridmx,nqmx)
+
+      REAL zdteuv(ngridmx,nlayermx)    ! (K/s)
+      REAL zdtconduc(ngridmx,nlayermx) ! (K/s)
+      REAL zdumolvis(ngridmx,nlayermx)
+      REAL zdvmolvis(ngridmx,nlayermx)
+      real zdqmoldiff(ngridmx,nlayermx,nqmx)
+
+c     Local variable for local intermediate calcul:
+      REAL zflubid(ngridmx)
+      REAL zplanck(ngridmx),zpopsk(ngridmx,nlayermx)
+      REAL zdum1(ngridmx,nlayermx)
+      REAL zdum2(ngridmx,nlayermx)
+      REAL ztim1,ztim2,ztim3, z1,z2
+      REAL ztime_fin
+      REAL zdh(ngridmx,nlayermx)
+      REAL pclc_min ! minimum of the cloud fraction over the whole domain
+      INTEGER length
+      PARAMETER (length=100)
+
+c local variables only used for diagnostic (output in file "diagfi" or "stats")
+c -----------------------------------------------------------------------------
+      REAL ps(ngridmx), zt(ngridmx,nlayermx)
+      REAL zu(ngridmx,nlayermx),zv(ngridmx,nlayermx)
+      REAL zq(ngridmx,nlayermx,nqmx)
+      REAL fluxtop_sw_tot(ngridmx), fluxsurf_sw_tot(ngridmx)
+      character*2 str2
+      character*5 str5
+      real zdtdif(ngridmx,nlayermx), zdtadj(ngridmx,nlayermx)
+      real reff(ngridmx,nlayermx) ! effective dust radius (used if doubleq=T)
+      real qtot1,qtot2 ! total aerosol mass
+      integer igmin, lmin
+      logical tdiag
+
+
+      REAL zplev(ngrid,nlayermx+1),zplay(ngrid,nlayermx)
+      REAL zstress(ngrid), cd
+      real hco2(nqmx),tmean, zlocal(nlayermx)
+      real rho(ngridmx,nlayermx) ! density
+      real vmr(ngridmx,nlayermx) ! volume mixing ratio
+
+      REAL time_phys
+     
+c=======================================================================
+
+c 1. Initialisation:
+c -----------------
+
+c  1.1   Initialisation only at first call
+c  ---------------------------------------
+      IF (firstcall) THEN
+
+c        variables set to 0
+c        ~~~~~~~~~~~~~~~~~~
+         call zerophys(ngrid*nlayer*naerkind,aerosol)
+         call zerophys(ngrid*nlayer,dtrad)
+         call zerophys(ngrid,fluxrad)
+
+c        read startfi 
+c        ~~~~~~~~~~~~
+
+! Read netcdf initial physical parameters.
+         CALL phyetat0 ("startfi.nc",0,0,
+     &         nsoilmx,nq,
+     &         day_ini,time_phys,
+     &         tsurf,tsoil,emis,q2,qsurf,co2ice)
+
+         if (pday.ne.day_ini) then
+           write(*,*) "PHYSIQ: ERROR: bad synchronization between ",
+     &                "physics and dynamics"
+           write(*,*) "dynamics day: ",pday
+           write(*,*) "physics day:  ",day_ini
+           stop
+         endif
+
+         write (*,*) 'In physiq day_ini =', day_ini
+
+c        Initialize albedo and orbital calculation
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+         CALL surfini(ngrid,co2ice,qsurf,albedo)
+         CALL iniorbit(aphelie,periheli,year_day,peri_day,obliquit)
+
+c        initialize soil 
+c        ~~~~~~~~~~~~~~~
+         IF (callsoil) THEN
+            CALL soil(ngrid,nsoilmx,firstcall,inertiedat,
+     s          ptimestep,tsurf,tsoil,capcal,fluxgrd)
+         ELSE
+            PRINT*,'WARNING! Thermal conduction in the soil turned off'
+            DO ig=1,ngrid
+               capcal(ig)=1.e5
+               fluxgrd(ig)=0.
+            ENDDO
+         ENDIF
+         icount=1
+
+
+c        initialize tracers
+c        ~~~~~~~~~~~~~~~~~~
+         tracerdyn=tracer
+         IF (tracer) THEN
+            CALL initracer(qsurf,co2ice)
+         ENDIF  ! end tracer
+
+c        Determining gridpoint near Viking Lander 1 (used for diagnostic only)
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+         if(ngrid.ne.1) then
+           latvl1= 22.27 
+           lonvl1= -47.94 
+           ig_vl1= 1+ int( (1.5-(latvl1-90.)*jjm/180.)  -2 )*iim +
+     &              int(1.5+(lonvl1+180)*iim/360.)
+           write(*,*) 'Viking Lander 1 GCM point: lat,lon',
+     &              lati(ig_vl1)*180/pi, long(ig_vl1)*180/pi
+         end if 
+
+c        Initialize thermospheric parameters
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+         if (callthermos) call param_read
+
+c        Initialize R and Cp as constant
+
+         if (.not.callthermos .and. .not.photochem) then
+                 do l=1,nlayermx
+                  do ig=1,ngridmx
+                   rnew(ig,l)=r
+                   cpnew(ig,l)=cpp
+                   mmean(ig,l)=mugaz
+                   enddo
+                  enddo  
+         endif         
+                   
+      ENDIF        !  (end of "if firstcall")
+
+c ---------------------------------------------------
+c 1.2   Initializations done at every physical timestep:
+c ---------------------------------------------------
+c
+      IF (ngrid.NE.ngridmx) THEN
+         PRINT*,'STOP in PHYSIQ'
+         PRINT*,'Probleme de dimensions :'
+         PRINT*,'ngrid     = ',ngrid
+         PRINT*,'ngridmx   = ',ngridmx
+         STOP
+      ENDIF
+
+c     Initialize various variables
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      call zerophys(ngrid*nlayer, pdv)
+      call zerophys(ngrid*nlayer, pdu)
+      call zerophys(ngrid*nlayer, pdt)
+      call zerophys(ngrid*nlayer*nq, pdq)
+      call zerophys(ngrid, pdpsrf)
+      call zerophys(ngrid, zflubid)
+      call zerophys(ngrid, zdtsurf)
+      call zerophys(ngrid*nq, dqsurf)
+      igout=ngrid/2+1 
+
+
+      zday=pday+ptime ! compute time, in sols (and fraction thereof)
+
+c     Compute Solar Longitude (Ls) :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      if (season) then
+         call solarlong(zday,zls)
+      else
+         call solarlong(float(day_ini),zls)
+      end if
+
+c     Compute geopotential at interlayers
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     ponderation des altitudes au niveau des couches en dp/p
+
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            zzlay(ig,l)=pphi(ig,l)/g
+         ENDDO
+      ENDDO
+      DO ig=1,ngrid
+         zzlev(ig,1)=0.
+         zzlev(ig,nlayer+1)=1.e7    ! dummy top of last layer above 10000 km...
+      ENDDO
+      DO l=2,nlayer
+         DO ig=1,ngrid
+            z1=(pplay(ig,l-1)+pplev(ig,l))/(pplay(ig,l-1)-pplev(ig,l))
+            z2=(pplev(ig,l)+pplay(ig,l))/(pplev(ig,l)-pplay(ig,l))
+            zzlev(ig,l)=(z1*zzlay(ig,l-1)+z2*zzlay(ig,l))/(z1+z2)
+         ENDDO
+      ENDDO
+
+
+!     Potential temperature calculation not the same in physiq and dynamic
+
+c     Compute potential temperature
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      DO l=1,nlayer
+         DO ig=1,ngrid 
+            zpopsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**rcp
+            zh(ig,l)=pt(ig,l)/zpopsk(ig,l)
+         ENDDO
+      ENDDO
+
+c-----------------------------------------------------------------------
+c    1.2.5 Compute mean mass, cp, and R
+c    --------------------------------
+
+      if(photochem.or.callthermos) then
+         call concentrations(pplay,pt,pdt,pq,pdq,ptimestep)
+      endif
+c-----------------------------------------------------------------------
+c    2. Compute radiative tendencies :
+c------------------------------------
+
+
+      IF (callrad) THEN
+         IF( MOD(icount-1,iradia).EQ.0) THEN
+
+c          Local Solar zenith angle
+c          ~~~~~~~~~~~~~~~~~~~~~~~~
+           CALL orbite(zls,dist_sol,declin)
+
+           IF(diurnal) THEN
+               ztim1=SIN(declin)
+               ztim2=COS(declin)*COS(2.*pi*(zday-.5))
+               ztim3=-COS(declin)*SIN(2.*pi*(zday-.5))
+
+               CALL solang(ngrid,sinlon,coslon,sinlat,coslat,
+     s         ztim1,ztim2,ztim3, mu0,fract)
+
+           ELSE
+               CALL mucorr(ngrid,declin, lati, mu0, fract,10000.,rad)
+           ENDIF
+
+c          NLTE cooling from CO2 emission
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+           IF(callnlte) CALL nltecool(ngrid,nlayer,pplay,pt,zdtnlte)
+
+c          Find number of layers for LTE radiation calculations
+           IF(MOD(iphysiq*(icount-1),day_step).EQ.0)
+     &          CALL nlthermeq(ngrid,nlayer,pplev,pplay)
+
+
+c          Atmospheric dust opacity and aerosol distribution:
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           CALL dustopacity(ngrid,nlayer,nq,zday,pplay,pplev,zls,pq,
+     $      tauref,tau,aerosol)
+         
+c          Call main radiative transfer scheme
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c          Transfer through dust and CO2, except NIR CO2 absorption
+
+           CALL callradite(icount,ngrid,nlayer,aerosol,albedo,
+     $     emis,mu0,pplev,pplay,pt,tsurf,fract,dist_sol,igout,
+     $     zdtlw,zdtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw,fluxtop_sw)
+
+c          CO2 near infrared absorption
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           call zerophys(ngrid*nlayer,zdtnirco2)
+           if (callnirco2) then
+              call nirco2abs (ngrid,nlayer,pplay,dist_sol,
+     .                       mu0,fract,declin, zdtnirco2)
+           endif
+
+c          Radiative flux from the sky absorbed by the surface (W.m-2)
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           DO ig=1,ngrid
+               fluxrad_sky(ig)=emis(ig)*fluxsurf_lw(ig)
+     $         +fluxsurf_sw(ig,1)*(1.-albedo(ig,1))
+     $         +fluxsurf_sw(ig,2)*(1.-albedo(ig,2))
+           ENDDO
+
+
+c          Net atmospheric radiative heating rate (K.s-1)
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           IF(callnlte) THEN
+              CALL blendrad(ngrid, nlayer, pplay,
+     &             zdtsw, zdtlw, zdtnirco2, zdtnlte, dtrad)
+           ELSE
+              DO l=1,nlayer
+                 DO ig=1,ngrid
+                    dtrad(ig,l)=zdtsw(ig,l)+zdtlw(ig,l)
+     &                          +zdtnirco2(ig,l)
+                  ENDDO
+              ENDDO
+           ENDIF
+
+
+
+        ENDIF ! of if(mod(icount-1,iradia).eq.0)
+
+
+
+c    Transformation of the radiative tendencies:
+c    -------------------------------------------
+
+c          Net radiative surface flux (W.m-2)
+c          ~~~~~~~~~~~~~~~~~~~~~~~~~~
+c
+           DO ig=1,ngrid
+               zplanck(ig)=tsurf(ig)*tsurf(ig)
+               zplanck(ig)=emis(ig)*
+     $         stephan*zplanck(ig)*zplanck(ig)
+               fluxrad(ig)=fluxrad_sky(ig)-zplanck(ig)
+           ENDDO
+
+
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               pdt(ig,l)=pdt(ig,l)+dtrad(ig,l)
+            ENDDO
+         ENDDO
+
+      ENDIF ! of IF (callrad)
+
+c-----------------------------------------------------------------------
+c    3. Gravity wave and subgrid scale topography drag :
+c    -------------------------------------------------
+
+
+      IF(calllott)THEN
+
+        CALL calldrag_noro(ngrid,nlayer,ptimestep,
+     &                 pplay,pplev,pt,pu,pv,zdtgw,zdugw,zdvgw)
+ 
+        DO l=1,nlayer
+          DO ig=1,ngrid
+            pdv(ig,l)=pdv(ig,l)+zdvgw(ig,l)
+            pdu(ig,l)=pdu(ig,l)+zdugw(ig,l)
+            pdt(ig,l)=pdt(ig,l)+zdtgw(ig,l)
+          ENDDO
+        ENDDO
+      ENDIF
+
+c-----------------------------------------------------------------------
+c    4. Vertical diffusion (turbulent mixing):
+c    -----------------------------------------
+c
+      IF (calldifv) THEN
+
+
+         DO ig=1,ngrid
+            zflubid(ig)=fluxrad(ig)+fluxgrd(ig)
+         ENDDO
+
+         CALL zerophys(ngrid*nlayer,zdum1)
+         CALL zerophys(ngrid*nlayer,zdum2)
+         do l=1,nlayer
+            do ig=1,ngrid
+               zdh(ig,l)=pdt(ig,l)/zpopsk(ig,l)
+            enddo
+         enddo
+
+c        Calling vdif (Martian version WITH CO2 condensation)
+         CALL vdifc(ngrid,nlayer,nq,co2ice,zpopsk,
+     $        ptimestep,capcal,lwrite,
+     $        pplay,pplev,zzlay,zzlev,z0,
+     $        pu,pv,zh,pq,tsurf,emis,qsurf,
+     $        zdum1,zdum2,zdh,pdq,zflubid,
+     $        zdudif,zdvdif,zdhdif,zdtsdif,q2,
+     &        zdqdif,zdqsdif)
+
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               pdv(ig,l)=pdv(ig,l)+zdvdif(ig,l)
+               pdu(ig,l)=pdu(ig,l)+zdudif(ig,l)
+               pdt(ig,l)=pdt(ig,l)+zdhdif(ig,l)*zpopsk(ig,l)
+
+               zdtdif(ig,l)=zdhdif(ig,l)*zpopsk(ig,l) ! for diagnostic only
+
+            ENDDO
+         ENDDO
+
+         DO ig=1,ngrid
+            zdtsurf(ig)=zdtsurf(ig)+zdtsdif(ig)
+         ENDDO
+
+         if (tracer) then 
+           DO iq=1, nq
+            DO l=1,nlayer
+              DO ig=1,ngrid
+                 pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqdif(ig,l,iq) 
+              ENDDO
+            ENDDO
+           ENDDO
+           DO iq=1, nq
+              DO ig=1,ngrid
+                 dqsurf(ig,iq)=dqsurf(ig,iq) + zdqsdif(ig,iq)
+              ENDDO
+           ENDDO
+         end if ! of if (tracer)
+
+      ELSE    
+         DO ig=1,ngrid
+            zdtsurf(ig)=zdtsurf(ig)+
+     s      (fluxrad(ig)+fluxgrd(ig))/capcal(ig)
+         ENDDO
+      ENDIF ! of IF (calldifv)
+
+
+c-----------------------------------------------------------------------
+c   5. Dry convective adjustment:
+c   -----------------------------
+
+      IF(calladj) THEN
+
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               zdh(ig,l)=pdt(ig,l)/zpopsk(ig,l)
+            ENDDO
+         ENDDO
+         CALL zerophys(ngrid*nlayer,zduadj)
+         CALL zerophys(ngrid*nlayer,zdvadj)
+         CALL zerophys(ngrid*nlayer,zdhadj)
+
+         CALL convadj(ngrid,nlayer,nq,ptimestep,
+     $                pplay,pplev,zpopsk,
+     $                pu,pv,zh,pq,
+     $                pdu,pdv,zdh,pdq,
+     $                zduadj,zdvadj,zdhadj,
+     $                zdqadj)
+
+         DO l=1,nlayer
+            DO ig=1,ngrid
+               pdu(ig,l)=pdu(ig,l)+zduadj(ig,l)
+               pdv(ig,l)=pdv(ig,l)+zdvadj(ig,l)
+               pdt(ig,l)=pdt(ig,l)+zdhadj(ig,l)*zpopsk(ig,l)
+
+               zdtadj(ig,l)=zdhadj(ig,l)*zpopsk(ig,l) ! for diagnostic only
+            ENDDO
+         ENDDO
+
+         if(tracer) then 
+           DO iq=1, nq
+            DO l=1,nlayer
+              DO ig=1,ngrid
+                 pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqadj(ig,l,iq) 
+              ENDDO
+            ENDDO
+           ENDDO
+         end if
+      ENDIF ! of IF(calladj)
+
+c-----------------------------------------------------------------------
+c   6. Carbon dioxide condensation-sublimation:
+c   -------------------------------------------
+
+      IF (callcond) THEN
+         CALL newcondens(ngrid,nlayer,nq,ptimestep,
+     $              capcal,pplay,pplev,tsurf,pt,
+     $              pphi,pdt,pdu,pdv,zdtsurf,pu,pv,pq,pdq,
+     $              co2ice,albedo,emis,
+     $              zdtc,zdtsurfc,pdpsrf,zduc,zdvc,zdqc,
+     $	            fluxsurf_sw) 
+
+         DO l=1,nlayer
+           DO ig=1,ngrid
+             pdt(ig,l)=pdt(ig,l)+zdtc(ig,l)
+             pdv(ig,l)=pdv(ig,l)+zdvc(ig,l)
+             pdu(ig,l)=pdu(ig,l)+zduc(ig,l)
+           ENDDO
+         ENDDO
+         DO ig=1,ngrid
+            zdtsurf(ig) = zdtsurf(ig) + zdtsurfc(ig)
+         ENDDO
+
+         IF (tracer) THEN
+           DO iq=1, nq
+            DO l=1,nlayer
+              DO ig=1,ngrid
+                pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqc(ig,l,iq) 
+              ENDDO
+            ENDDO
+           ENDDO
+         ENDIF ! of IF (tracer)
+
+      ENDIF  ! of IF (callcond)
+
+c-----------------------------------------------------------------------
+c   7. Specific parameterizations for tracers 
+c:   -----------------------------------------
+
+      if (tracer) then 
+
+c   7a. Water and ice
+c     ---------------
+
+c        ---------------------------------------
+c        Water ice condensation in the atmosphere
+c        ----------------------------------------
+         IF (water) THEN
+           call watercloud(ngrid,nlayer, ptimestep,
+     &                pplev,pplay,pdpsrf,zzlev,zzlay, pt,pdt,
+     &                pq,pdq,zdqcloud,qsurf,zdqscloud,zdtcloud,
+     &                nq,naerkind,tau,icount,zls)
+
+           if (activice) then
+c Temperature variation due to latent heat release
+           DO l=1,nlayer
+             DO ig=1,ngrid
+               pdt(ig,l)=pdt(ig,l)+zdtcloud(ig,l)
+             ENDDO
+           ENDDO
+           endif
+
+           IF (iceparty) then
+             iqmin=nq-1
+           ELSE
+             iqmin=nq
+           ENDIF
+
+           DO iq=iqmin,nq
+             DO l=1,nlayer
+                DO ig=1,ngrid
+                   pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqcloud(ig,l,iq)
+                ENDDO
+             ENDDO
+             DO ig=1,ngrid
+                dqsurf(ig,iq)= dqsurf(ig,iq) + zdqscloud(ig,iq)
+             ENDDO
+           ENDDO
+
+         END IF  ! of IF (water)
+
+c   7b. Chemical species
+c     ------------------
+
+c        --------------
+c        photochemistry :
+c        --------------
+         IF (photochem .or. thermochem) then
+          call calchim(ptimestep,pplay,pplev,pt,pdt,dist_sol,mu0,
+     .      zzlay,zday,pq,pdq,zdqchim,zdqschim,zdqcloud,zdqscloud)
+           
+c Photochemistry includes condensation of H2O2
+
+           do iq=nqchem_min,nq
+            if (noms(iq).eq."h2o2") then
+             DO l=1,nlayer
+               DO ig=1,ngrid
+                    pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqchim(ig,l,iq)
+                    pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqcloud(ig,l,iq)
+               ENDDO
+             ENDDO
+            else
+             DO l=1,nlayer
+               DO ig=1,ngrid
+                    pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqchim(ig,l,iq)
+               ENDDO
+             ENDDO
+            endif
+           ENDDO
+           do iq=nqchem_min,nq
+            if (noms(iq).eq."h2o2") then
+               DO ig=1,ngrid
+                    dqsurf(ig,iq)= dqsurf(ig,iq) + zdqschim(ig,iq)
+                    dqsurf(ig,iq)= dqsurf(ig,iq) + zdqscloud(ig,iq)
+               ENDDO
+            else
+               DO ig=1,ngrid
+                    dqsurf(ig,iq)= dqsurf(ig,iq) + zdqschim(ig,iq)
+               ENDDO
+            endif
+           ENDDO
+
+         END IF  ! of IF (photochem.or.thermochem)
+
+c   7c. Aerosol particles
+c     -------------------
+
+c        ----------
+c        Dust devil :
+c        ----------
+         IF(callddevil) then 
+           call dustdevil(ngrid,nlayer,nq, pplev,pu,pv,pt, tsurf,q2,
+     &                zdqdev,zdqsdev)
+ 
+           if (dustbin.ge.1) then
+              do iq=1,nq
+                 DO l=1,nlayer
+                    DO ig=1,ngrid
+                       pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqdev(ig,l,iq)
+                    ENDDO
+                 ENDDO
+              enddo
+              do iq=1,nq
+                 DO ig=1,ngrid
+                    dqsurf(ig,iq)= dqsurf(ig,iq) + zdqsdev(ig,iq)
+                 ENDDO
+              enddo
+           endif  ! of if (dustbin.ge.1)
+
+         END IF ! of IF (callddevil)
+
+c        ------------- 
+c        Sedimentation :   acts also on water ice
+c        ------------- 
+         IF (sedimentation) THEN 
+           call zerophys(ngrid*nlayer*nq, zdqsed)
+           call zerophys(ngrid*nq, zdqssed)
+
+           if(doubleq) then
+            call callsedim2q(ngrid,nlayer, ptimestep,
+     &                pplev,zzlev, pt,
+     &                pq, pdq, zdqsed, zdqssed,nq)
+           else
+            call callsedim(ngrid,nlayer, ptimestep,
+     &                pplev,zzlev, pt,
+     &                pq, pdq, zdqsed, zdqssed,nq)
+           end if
+
+
+           DO iq=1, nq
+             DO l=1,nlayer
+               DO ig=1,ngrid
+                    pdq(ig,l,iq)=pdq(ig,l,iq)+ zdqsed(ig,l,iq)
+               ENDDO
+             ENDDO
+           ENDDO
+           DO iq=1, nq
+             DO ig=1,ngrid
+                dqsurf(ig,iq)= dqsurf(ig,iq) + zdqssed(ig,iq)
+             ENDDO
+           ENDDO
+         END IF   ! of IF (sedimentation)
+
+c   7d. Updates
+c     ---------
+
+        DO iq=1, nq
+          DO ig=1,ngrid
+
+c       ---------------------------------
+c       Updating tracer budget on surface
+c       ---------------------------------
+            qsurf(ig,iq)=qsurf(ig,iq)+ptimestep*dqsurf(ig,iq)
+
+          ENDDO  ! (ig)
+        ENDDO    ! (iq)
+
+      endif !  of if (tracer) 
+
+
+c-----------------------------------------------------------------------
+c   8. THERMOSPHERE CALCULATION
+c-----------------------------------------------------------------------
+
+      if (callthermos) then
+        call thermosphere(pplev,pplay,dist_sol,
+     $     mu0,ptimestep,ptime,zday,tsurf,zzlev,zzlay,
+     &     pt,pq,pu,pv,pdt,pdq,
+     $     zdteuv,zdtconduc,zdumolvis,zdvmolvis,zdqmoldiff)
+c           do iq=nqchem_min,nq
+c           write(*,*) 'thermo iq,pq',iq,pq(690,1,iq)
+c           enddo
+
+        DO l=1,nlayer
+          DO ig=1,ngrid
+            dtrad(ig,l)=dtrad(ig,l)+zdteuv(ig,l)
+            pdt(ig,l)=pdt(ig,l)+zdtconduc(ig,l)
+     &                         +zdteuv(ig,l)
+            pdv(ig,l)=pdv(ig,l)+zdvmolvis(ig,l)
+            pdu(ig,l)=pdu(ig,l)+zdumolvis(ig,l)
+            DO iq=1, nq
+              pdq(ig,l,iq)=pdq(ig,l,iq)+zdqmoldiff(ig,l,iq)
+            ENDDO
+          ENDDO
+        ENDDO
+
+
+      endif
+c-----------------------------------------------------------------------
+c   9. Surface  and sub-surface soil temperature
+c-----------------------------------------------------------------------
+c
+c
+c   9.1 Increment Surface temperature:
+c   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+      DO ig=1,ngrid
+         tsurf(ig)=tsurf(ig)+ptimestep*zdtsurf(ig) 
+      ENDDO
+
+c  Prescribe a cold trap at south pole (except at high obliquity !!)
+c  Temperature at the surface is set there to be the temperature
+c  corresponding to equilibrium temperature between phases of CO2
+
+      IF (tracer.AND.water.AND.ngridmx.NE.1) THEN
+         if (caps.and.(obliquit.lt.27.)) then
+           ! NB: Updated surface pressure, at grid point 'ngrid', is
+           !     ps(ngrid)=pplev(ngrid,1)+pdpsrf(ngrid)*ptimestep
+           tsurf(ngrid)=1./(1./136.27-r/5.9e+5*alog(0.0095*
+     &                     (pplev(ngrid,1)+pdpsrf(ngrid)*ptimestep)))
+         endif
+c       -------------------------------------------------------------
+c       Change of surface albedo (set to 0.4) in case of ground frost
+c       everywhere except on the north permanent cap and in regions
+c       covered by dry ice. 
+c              ALWAYS PLACE these lines after newcondens !!!
+c       -------------------------------------------------------------
+         do ig=1,ngrid
+
+c       -------------- Version temporaire fit TES 2008 ------------
+         if (co2ice(ig).eq.0.and.qsurf(ig,nqmx).gt.0.005) then
+              albedo(ig,1)=0.45                                     
+              albedo(ig,2)=0.45                                     
+          endif
+
+c         if (co2ice(ig).eq.0.and.qsurf(ig,nqmx).gt.0.005) then
+c           if (.not.watercaptag(ig)) then
+c             albedo(ig,1)=0.4
+c             albedo(ig,2)=0.4
+c           endif
+c         endif
+c       -------------- version Francois ---------------
+c          if (co2ice(ig).eq.0.and.
+c    &        ((qsurf(ig,nqmx).gt.0.005).or.(watercaptag(ig)))) then
+c              albedo(ig,1)=max(0.4,albedodat(ig))
+c              albedo(ig,2)=albedo(ig,1)
+c          endif
+c       ---------------------------------------------
+         enddo  ! of do ig=1,ngrid
+      ENDIF  ! of IF (tracer.AND.water.AND.ngridmx.NE.1)
+
+c
+c   9.2 Compute soil temperatures and subsurface heat flux:
+c   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      IF (callsoil) THEN
+         CALL soil(ngrid,nsoilmx,.false.,inertiedat,
+     &          ptimestep,tsurf,tsoil,capcal,fluxgrd)
+      ENDIF
+
+c-----------------------------------------------------------------------
+c  10. Write output files
+c  ----------------------
+
+c    -------------------------------
+c    Dynamical fields incrementation
+c    -------------------------------
+c (FOR OUTPUT ONLY : the actual model integration is performed in the dynamics)
+      ! temperature, zonal and meridional wind
+      DO l=1,nlayer
+        DO ig=1,ngrid
+          zt(ig,l)=pt(ig,l)  + pdt(ig,l)*ptimestep
+          zu(ig,l)=pu(ig,l)  + pdu(ig,l)*ptimestep
+          zv(ig,l)=pv(ig,l)  + pdv(ig,l)*ptimestep
+        ENDDO
+      ENDDO
+
+      ! tracers
+      DO iq=1, nq
+        DO l=1,nlayer
+          DO ig=1,ngrid
+            zq(ig,l,iq)=pq(ig,l,iq) +pdq(ig,l,iq)*ptimestep
+          ENDDO
+        ENDDO
+      ENDDO
+
+      ! surface pressure
+      DO ig=1,ngrid
+          ps(ig)=pplev(ig,1) + pdpsrf(ig)*ptimestep
+      ENDDO
+
+      ! pressure
+      DO l=1,nlayer
+        DO ig=1,ngrid
+             zplev(ig,l)=pplev(ig,l)/pplev(ig,1)*ps(ig)
+             zplay(ig,l)=pplay(ig,l)/pplev(ig,1)*ps(ig)
+        ENDDO
+      ENDDO
+
+      ! Density 
+      DO l=1,nlayer
+         DO ig=1,ngrid
+            rho(ig,l) = zplay(ig,l)/(rnew(ig,l)*zt(ig,l))
+         ENDDO
+      ENDDO
+
+c    Compute surface stress : (NB: z0 is a common in planete.h)
+c     DO ig=1,ngrid
+c        cd = (0.4/log(zzlay(ig,1)/z0))**2
+c        zstress(ig) = rho(ig,1)*cd*(zu(ig,1)**2 + zv(ig,1)**2)
+c     ENDDO
+
+c     Sum of fluxes in solar spectral bands (for output only)
+      DO ig=1,ngrid
+	     fluxtop_sw_tot(ig)=fluxtop_sw(ig,1) + fluxtop_sw(ig,2)
+	     fluxsurf_sw_tot(ig)=fluxsurf_sw(ig,1) + fluxsurf_sw(ig,2)
+      ENDDO
+c ******* TEST ******************************************************
+      ztim1 = 999
+      DO l=1,nlayer
+        DO ig=1,ngrid
+           if (pt(ig,l).lt.ztim1) then
+               ztim1 = pt(ig,l)
+               igmin = ig
+               lmin = l 
+           end if
+        ENDDO
+      ENDDO
+      if(min(pt(igmin,lmin),zt(igmin,lmin)).lt.70.) then	
+        write(*,*) 'PHYSIQ: stability WARNING :'
+        write(*,*) 'pt, zt Tmin = ', pt(igmin,lmin), zt(igmin,lmin),
+     &              'ig l =', igmin, lmin
+      end if
+c *******************************************************************
+
+c     ---------------------
+c     Outputs to the screen 
+c     ---------------------
+
+      IF (lwrite) THEN
+         PRINT*,'Global diagnostics for the physics'
+         PRINT*,'Variables and their increments x and dx/dt * dt'
+         WRITE(*,'(a6,a10,2a15)') 'Ts','dTs','ps','dps'
+         WRITE(*,'(2f10.5,2f15.5)')
+     s   tsurf(igout),zdtsurf(igout)*ptimestep,
+     s   pplev(igout,1),pdpsrf(igout)*ptimestep
+         WRITE(*,'(a4,a6,5a10)') 'l','u','du','v','dv','T','dT'
+         WRITE(*,'(i4,6f10.5)') (l,
+     s   pu(igout,l),pdu(igout,l)*ptimestep,
+     s   pv(igout,l),pdv(igout,l)*ptimestep,
+     s   pt(igout,l),pdt(igout,l)*ptimestep,
+     s   l=1,nlayer)
+      ENDIF ! of IF (lwrite)
+
+
+      IF (ngrid.NE.1) THEN
+         print*,'Ls =',zls*180./pi,
+     &   ' tauref(700 Pa,lat=0) =',tauref(ngrid/2),
+     &   ' tau(Viking1) =',tau(ig_vl1,1)
+
+c        -------------------------------------------------------------------
+c        Writing NetCDF file  "RESTARTFI" at the end of the run
+c        -------------------------------------------------------------------
+c        Note: 'restartfi' is stored just before dynamics are stored
+c              in 'restart'. Between now and the writting of 'restart',
+c              there will have been the itau=itau+1 instruction and
+c              a reset of 'time' (lastacll = .true. when itau+1= itaufin)
+c              thus we store for time=time+dtvr
+
+         IF(lastcall) THEN
+            ztime_fin = ptime + ptimestep/(float(iphysiq)*daysec) 
+            write(*,*)'PHYSIQ: for physdem ztime_fin =',ztime_fin
+            call physdem1("restartfi.nc",long,lati,nsoilmx,nq,
+     .              ptimestep,pday,
+     .              ztime_fin,tsurf,tsoil,co2ice,emis,q2,qsurf,
+     .              area,albedodat,inertiedat,zmea,zstd,zsig,
+     .              zgam,zthe)
+         ENDIF
+
+c        -----------------------------------------------------------------
+c        Saving statistics :
+c        -----------------------------------------------------------------
+c        ("stats" stores and accumulates 8 key variables in file "stats.nc"
+c        which can later be used to make the statistic files of the run:
+c        "stats")          only possible in 3D runs !
+
+         
+         IF (callstats) THEN
+
+
+            call wstats(ngrid,"ps","Surface pressure","K",2,ps)
+            call wstats(ngrid,"tsurf","Surface temperature","K",2,tsurf)
+            call wstats(ngrid,"co2ice","CO2 ice cover",
+     .                  "kg.m-2",2,co2ice)
+c            call wstats(ngrid,"emis","Surface emissivity","w.m-1",2,
+c    .                  emis)
+             call wstats(ngrid,"fluxsurf_lw",
+     .                 "Thermal IR radiative flux to surface","W.m-2",2,
+     .                 fluxsurf_lw)
+             call wstats(ngrid,"fluxsurf_sw",
+     .                  "Solar radiative flux to surface","W.m-2",2,
+     .                   fluxsurf_sw_tot)
+             call wstats(ngrid,"fluxtop_lw",
+     .                  "Thermal IR radiative flux to space","W.m-2",2,
+     .                  fluxtop_lw)
+             call wstats(ngrid,"fluxtop_sw",
+     .                  "Solar radiative flux to space","W.m-2",2,
+     .                  fluxtop_sw_tot)
+            call wstats(ngrid,"dod","Dust optical depth"," ",2,tau)
+
+            call wstats(ngrid,"temp","Atmospheric temperature","K",3,zt)
+            call wstats(ngrid,"u","Zonal (East-West) wind","m.s-1",3,zu)
+            call wstats(ngrid,"v","Meridional (North-South) wind",
+     .                  "m.s-1",3,zv)
+            call wstats(ngrid,"w","Vertical (down-up) wind",
+     .                  "m.s-1",3,pw)
+            call wstats(ngrid,"rho","Atmospheric density","none",3,rho)
+             call wstats(ngrid,"q2",
+     .               "Boundary layer eddy kinetic energy","m2.s-2",3,q2)
+
+           if (tracer) then
+            if (water) then
+               vmr=zq(1:ngridmx,1:nlayermx,nqmx)*mugaz/mmol(nqmx)
+               call wstats(ngrid,"vmr_h2ovapor",
+     .                    "H2O vapor volume mixing ratio","mol/mol",
+     .                    3,vmr)
+               if (iceparty) then
+                  vmr=zq(1:ngridmx,1:nlayermx,nqmx-1)*mugaz/mmol(nqmx-1)
+                  call wstats(ngrid,"vmr_h2oice",
+     .                       "H2O ice volume mixing ratio","mol/mol",
+     .                       3,vmr)
+               endif
+            endif
+
+             if (thermochem.or.photochem) then
+                do iq=1,nq
+                   if ((noms(iq).eq."o").or.(noms(iq).eq."co2").or.
+     .               (noms(iq).eq."co").or.(noms(iq).eq."n2").or.
+     .               (noms(iq).eq."h2").or.
+     .               (noms(iq).eq."o3")) then
+                        do l=1,nlayer
+                          do ig=1,ngrid
+                            vmr(ig,l)=zq(ig,l,iq)*mmean(ig,l)/mmol(iq)
+                          end do
+                        end do
+                        call wstats(ngrid,"vmr_"//trim(noms(iq)),
+     .                     "Volume mixing ratio","mol/mol",3,vmr)
+                   endif
+                enddo
+             endif
+           endif !tracer 
+
+            IF(lastcall) THEN
+              write (*,*) "Writing stats..."
+              call mkstats(ierr)
+            ENDIF
+          ENDIF !if callstats
+
+c        (Store EOF for Mars Climate database software)
+         IF (calleofdump) THEN
+            CALL eofdump(ngrid, nlayer, zu, zv, zt, rho, ps)
+         ENDIF
+
+
+c        ----------------------------------------------------------------------
+c        output in netcdf file "DIAGFI", containing any variable for diagnostic
+c        (output with  period "ecritphy", set in "run.def")
+c        ----------------------------------------------------------------------
+c        WRITEDIAGFI can ALSO be called from any other subroutines
+c        for any variables !!
+       call WRITEDIAGFI(ngrid,"emis","Surface emissivity","w.m-1",2,
+     .                  emis)
+        call WRITEDIAGFI(ngrid,"tsurf","Surface temperature","K",2,
+     .                  tsurf)
+        call WRITEDIAGFI(ngrid,"ps","surface pressure","K",2,ps)
+        call WRITEDIAGFI(ngrid,"co2ice","co2 ice thickness","kg.m-2",2,
+     .                  co2ice)
+c       call WRITEDIAGFI(ngrid,"fluxsurf_lw","fluxsurf_lw","W.m-2",2,
+c    .       fluxsurf_lw)
+c       call WRITEDIAGFI(ngrid,"fluxsurf_sw","fluxsurf_sw","W.m-2",2,
+c    .       fluxsurf_sw_tot)
+c       call WRITEDIAGFI(ngrid,"fluxtop_lw","fluxtop_lw","W.m-2",2,
+c    .       fluxtop_lw)
+c       call WRITEDIAGFI(ngrid,"fluxtop_sw","fluxtop_sw","W.m-2",2,
+c    .       fluxtop_sw_tot)
+        call WRITEDIAGFI(ngrid,"temp","temperature","K",3,zt)
+c        call WRITEDIAGFI(ngrid,"tau","tau"," ",2,tau)
+        call WRITEDIAGFI(ngrid,"u","Zonal wind","m.s-1",3,zu)
+        call WRITEDIAGFI(ngrid,"v","Meridional wind","m.s-1",3,zv)
+        call WRITEDIAGFI(ngrid,"w","Vertical wind","m.s-1",3,pw)
+c       call WRITEDIAGFI(ngrid,"rho","density","none",3,rho)
+c        call WRITEDIAGFI(ngrid,"q2","q2","kg.m-3",3,q2)
+c       call WRITEDIAGFI(ngridm,'Teta','T potentielle','K',3,zh)
+c       call WRITEDIAGFI(ngridm,'Pression','Pression','Pa',3,pplay)
+        call WRITEDIAGFI(ngrid,"tsoil","soil temperature","K",3,tsoil)
+
+
+c       OUTPUT of tracer mass mixing ratio and surface value :    
+       if (tracer) then
+c         (for photochemistry, outputs are done in calchim)
+          do iq=1,nqmx
+            write(str2(1:2),'(i2.2)') iq
+            call WRITEDIAGFI(ngridmx,'q'//str2,noms(iq),
+     &                         'kg/kg',3,zq(1,1,iq))
+            call WRITEDIAGFI(ngridmx,'qsurf'//str2,noms(iq),
+     &                     'kg.m-2',2,qsurf(1,iq))
+          end do
+        end if
+c ***************************************************
+
+c  Outputs for H2O
+       if (tracer) then
+        if (activice) then
+c         call WRITEDIAGFI(ngridmx,'tauice','tau','SI',2,tau(1,2))
+c         call WRITEDIAGFI(ngridmx,'sw_htrt','sw heat. rate',
+c     &                   'w.m-2',3,zdtsw)
+c         call WRITEDIAGFI(ngridmx,'lw_htrt','lw heat. rate',
+c     &                   'w.m-2',3,zdtlw)
+        endif  !(activice)
+
+        if (water.and..not.photochem) then
+           iq=nq
+c          write(str2(1:2),'(i2.2)') iq
+c          call WRITEDIAGFI(ngridmx,'dqs'//str2,'dqscloud',
+c     &                    'kg.m-2',2,zdqscloud(1,iq))
+c          call WRITEDIAGFI(ngridmx,'dqch'//str2,'var chim',
+c     &                    'kg/kg',3,zdqchim(1,1,iq))
+c          call WRITEDIAGFI(ngridmx,'dqd'//str2,'var dif',
+c     &                    'kg/kg',3,zdqdif(1,1,iq))
+c          call WRITEDIAGFI(ngridmx,'dqa'//str2,'var adj',
+c     &                    'kg/kg',3,zdqadj(1,1,iq))
+c          call WRITEDIAGFI(ngridmx,'dqc'//str2,'var c',
+c     &                    'kg/kg',3,zdqc(1,1,iq))
+        endif  !(water.and..not.photochem)
+
+c       if (iceparty) then
+c          iq=nq-1
+c          write(str2(1:2),'(i2.2)') iq
+c          call WRITEDIAGFI(ngridmx,'q'//str2,'mix. ratio',
+c    &                     'kg/kg',3,zq(1,1,iq))
+c       endif  !(iceparty)
+       endif
+
+c  Outputs for dust tracers
+
+         if (tracer.and.(dustbin.ne.0)) then
+            call WRITEDIAGFI(ngridmx,'tau','taudust','SI',2,tau(1,1))
+            if (doubleq) then
+               call WRITEDIAGFI(ngridmx,'qsurf','qsurf',
+     &                         'kg.m-2',2,qsurf(1,1))
+               call WRITEDIAGFI(ngridmx,'Nsurf','N particles',
+     &                         'N.m-2',2,qsurf(1,2))
+               call WRITEDIAGFI(ngridmx,'dqsdev','ddevil lift',
+     &                         'kg.m-2.s-1',2,zdqsdev(1,1))
+               call WRITEDIAGFI(ngridmx,'dqssed','sedimentation',
+     &                         'kg.m-2.s-1',2,zdqssed(1,1))
+               do  l=1,nlayer
+                  do ig=1, ngrid
+                     reff(ig,l)= ref_r0 *
+     &               (r3n_q*pq(ig,l,1)/max(pq(ig,l,2),0.01))**(1./3.)
+                     reff(ig,l)=min(max(reff(ig,l),1.e-10),500.e-6)
+                  end do
+               end do
+               call WRITEDIAGFI(ngridmx,'reff','reff','m',3,reff)
+            else
+               do iq=1,dustbin
+                  write(str2(1:2),'(i2.2)') iq
+                  call WRITEDIAGFI(ngridmx,'q'//str2,'mix. ratio',
+     &                            'kg/kg',3,zq(1,1,iq))
+                  call WRITEDIAGFI(ngridmx,'qsurf'//str2,'qsurf',
+     &                            'kg.m-2',2,qsurf(1,iq))
+               end do
+            endif ! (doubleq)
+         end if  ! (tracer.and.(dustbin.ne.0))
+
+
+      ELSE     ! if(ngrid.eq.1)
+
+         print*,'Ls =',zls*180./pi,
+     &  '  tauref(700 Pa) =',tauref,' local tau =',tau(1,1)
+c      ----------------------------------------------------------------------
+c      Output in grads file "g1d" (ONLY when using testphys1d)
+c      (output at every X physical timestep)
+c      ----------------------------------------------------------------------
+c
+c        CALL writeg1d(ngrid,1,fluxsurf_lw,'Fs_ir','W.m-2')
+c        CALL writeg1d(ngrid,1,tsurf,'tsurf','K')
+         CALL writeg1d(ngrid,1,ps,'ps','Pa')
+         
+         CALL writeg1d(ngrid,nlayer,zt,'T','K')
+c        CALL writeg1d(ngrid,nlayer,pu,'u','m.s-1')
+c        CALL writeg1d(ngrid,nlayer,pv,'v','m.s-1')
+c        CALL writeg1d(ngrid,nlayer,pw,'w','m.s-1')
+
+         if(tracer) then
+c           CALL writeg1d(ngrid,1,tau,'tau','SI')
+            do iq=1,nq
+              CALL writeg1d(ngrid,nlayer,zq(1,1,iq),noms(iq),'kg/kg') 
+            end do
+         end if
+
+         zlocal(1)=-log(pplay(1,1)/pplev(1,1))* Rnew(1,1)*zt(1,1)/g
+
+         do l=2,nlayer-1
+            tmean=zt(1,l)
+            if(zt(1,l).ne.zt(1,l-1))
+     &        tmean=(zt(1,l)-zt(1,l-1))/log(zt(1,l)/zt(1,l-1))
+              zlocal(l)= zlocal(l-1)
+     &        -log(pplay(1,l)/pplay(1,l-1))*rnew(1,l)*tmean/g
+         enddo
+         zlocal(nlayer)= zlocal(nlayer-1)-
+     &                   log(pplay(1,nlayer)/pplay(1,nlayer-1))*
+     &                   rnew(1,nlayer)*tmean/g
+
+c         if(tracer) then
+c         do l=2,nlayer
+c            do iq=1,nq
+c               hco2(iq)=zq(1,l,iq)/zq(1,l-1,iq)
+c               hco2(iq)=-(zlocal(l)-zlocal(l-1))/log(hco2(iq))/1000.
+c            enddo
+c            write(225,*) l,pt(1,l),(hco2(iq),iq=1,6)
+c            write(226,*) l,(hco2(iq),iq=7,13)
+c         enddo
+c         endif
+
+      END IF       ! if(ngrid.ne.1)
+
+
+      icount=icount+1
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/planete.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/planete.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/planete.h	(revision 57)
@@ -0,0 +1,14 @@
+c-----------------------------------------------------------------------
+c INCLUDE planet.h
+
+      COMMON/planet/aphelie,periheli,year_day,peri_day,
+     $       obliquit,
+     $       z0,lmixmin,emin_turb,coefvis,coefir,
+     $       timeperi,e_elips,p_elips,unitastr
+
+      REAL aphelie,periheli,year_day,peri_day,
+     $     obliquit,
+     $     z0,lmixmin,emin_turb,coefvis,coefir,
+     $       timeperi,e_elips,p_elips,unitastr
+
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/profile.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/profile.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/profile.F	(revision 57)
@@ -0,0 +1,223 @@
+      SUBROUTINE profile(unit,nlev,zkm,temp)
+      IMPLICIT NONE
+c=======================================================================
+c     Subroutine utilisee dans le modele 1-D  "testphys1d"
+c     pour l'initialisation du profil atmospherique
+c=======================================================================
+c
+c   differents profils d'atmospheres. T=f(z)
+c   entree:
+c     unit    unite de lecture de "testphys1d.def"
+c     nlev    nombre de niveaux
+c     zkm     alititudes en km
+c     ichoice choix de l'atmosphere:
+c             1 Temperature constante
+c             2 profil Savidjari
+c             3 Lindner (profil polaire)
+c             4 Inversion pour Francois
+c             5 Seiff (moyen)
+c             6 T constante + perturbation gauss (level) (christophe 10/98)
+c             7 T constante + perturbation gauss   (km)  (christophe 10/98)
+c             8 Lecture du profile dans un fichier ASCII (profile)
+c     tref    temperature de reference
+c     isin    ajout d'une perturbation (isin=1)
+c     pic     pic perturbation gauss pour ichoice = 6 ou 7
+c     largeur largeur de la perturbation gauss pour ichoice = 6 ou 7
+c     hauteur hauteur de la perturbation gauss pour ichoice = 6 ou 7
+c
+c   sortie:
+c     temp    temperatures en K
+c     
+c=======================================================================
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+c   arguments:
+c   ----------
+
+       INTEGER nlev, unit
+       REAL zkm(nlev),temp(nlev)
+
+c   local:
+c   ------
+
+      INTEGER il,ichoice,nseiff,iseiff,isin,iter
+      REAL pi
+      PARAMETER(nseiff=37)
+      REAL tref,t1,t2,t3,ww
+      REAL tseiff(nseiff)
+      DATA tseiff/214.,213.8,213.4,212.4,209.3,205.,201.4,197.8,
+     $           194.6,191.4,188.2,185.2,182.5,180.,177.5,175,
+     $           172.5,170.,167.5,164.8,162.4,160.,158.,156.,
+     $           154.1,152.2,150.3,148.7,147.2,145.7,144.2,143.,
+     $           142.,141.,140,139.5,139./
+      REAL pic,largeur
+      REAL hauteur,tmp
+
+c-----------------------------------------------------------------------
+c   choix du profile:
+c   -----------------
+
+      READ(unit,*) 
+      READ(unit,*) 
+      READ(unit,*) 
+      READ(unit,*) ichoice
+      READ(unit,*) tref
+      READ(unit,*,ERR=200) isin
+      READ(unit,*) pic
+      READ(unit,*) largeur
+      READ(unit,*) hauteur
+      GOTO 200
+100   STOP'fichier profile.def inexistant'
+200   CONTINUE
+      CLOSE(unit)
+c-----------------------------------------------------------------------
+c   ichoice=1 temperature constante:
+c   --------------------------------
+
+      IF(ichoice.EQ.1) THEN
+         DO il=1,nlev
+            temp(il)=tref
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=2 savidjari:
+c   --------------------
+
+      ELSE IF(ichoice.EQ.2) THEN
+         DO il=1,nlev
+            temp(il)=AMAX1(219.-2.5*zkm(il),140.)
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=3 Lindner:
+c   ------------------
+
+      ELSE IF(ichoice.EQ.3) THEN
+         DO il=1,nlev
+            IF(zkm(il).LT.2.5) THEN
+               temp(il)=150.+30.*zkm(il)/2.5
+            ELSE IF(zkm(il).LT.5.) THEN
+               temp(il)=180.
+            ELSE
+               temp(il)=AMAX1(180.-2.*(zkm(il)-5.),130.)
+            ENDIF
+         ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=4 Inversion pour Francois:
+c   ------------------
+
+      ELSE IF(ichoice.EQ.4) THEN
+         DO il=1,nlev
+            IF(zkm(il).LT.20.) THEN
+               temp(il)=135.
+            ELSE
+               temp(il)=AMIN1(135.+5.*(zkm(il)-20.),200.)
+            ENDIF
+         ENDDO
+
+
+c-----------------------------------------------------------------------
+c   ichoice=5 Seiff:
+c   ----------------
+
+      ELSE IF(ichoice.EQ.5) THEN
+	 DO il=1,nlev
+	    iseiff=INT(zkm(il)/2.)+1
+	    IF(iseiff.LT.nseiff-1) THEN
+	       temp(il)=tseiff(iseiff)+(zkm(il)-2.*(iseiff-1))*
+     $         (tseiff(iseiff+1)-tseiff(iseiff))/2.
+	    ELSE
+	       temp(il)=tseiff(nseiff)
+	    ENDIF
+	 ENDDO
+c IF(ichoice.EQ.6) THEN
+c	    DO iter=1,6
+c	    t2=temp(1)
+c	    t3=temp(2)
+c	    DO il=2,nlev-1
+c	       t1=t2
+c	       t2=t3
+c	       t3=temp(il+1)
+c	       ww=tanh(zkm(il)/20.)
+c	       ww=ww*ww*ww
+c	       temp(il)=t2+ww*.5*(t1-2.*t2+t3)
+c	    ENDDO
+c	    ENDDO
+c	 ENDIF
+
+c-----------------------------------------------------------------------
+c   ichoice=6 
+c   ---------
+
+      ELSE IF(ichoice.EQ.6) THEN
+      DO il=1,nlev
+        tmp=il-pic
+        temp(il)=tref + hauteur*exp(-tmp*tmp/largeur/largeur)
+      ENDDO
+
+
+c-----------------------------------------------------------------------
+c   ichoice=7
+c   ---------
+
+      ELSE IF(ichoice.EQ.7) THEN
+      DO il=1,nlev
+        tmp=zkm(il)-pic
+        temp(il)=tref + hauteur*exp(-tmp*tmp*4/largeur/largeur)
+      ENDDO
+
+c-----------------------------------------------------------------------
+c   ichoice=8
+c   ---------
+
+      ELSE IF(ichoice.GE.8) THEN
+      OPEN(11,file='profile',status='old',form='formatted',err=101)
+      DO il=1,nlev
+        READ (11,*) temp(il)
+      ENDDO
+
+      GOTO 201
+101   STOP'fichier profile inexistant'
+201   CONTINUE
+      CLOSE(10)
+
+c-----------------------------------------------------------------------
+
+      ENDIF
+
+c-----------------------------------------------------------------------
+c   rajout eventuel d'une perturbation:
+c   -----------------------------------
+
+      IF(isin.EQ.1) THEN
+	 pi=2.*ASIN(1.)
+	 DO il=1,nlev
+c       if (nlev.EQ.501) then
+c         if (zkm(il).LE.70.5) then
+c       temp(il)=temp(il)+(1.-1000./(1000+zkm(il)*zkm(il)))*(
+c    s      6.*SIN(zkm(il)*pi/6.)+9.*SIN(zkm(il)*pi/10.3) )
+c         endif
+c       else
+        temp(il)=temp(il)+(1.-1000./(1000+zkm(il)*zkm(il)))*(
+     s      6.*SIN(zkm(il)*pi/6.)+9.*SIN(zkm(il)*pi/10.3) )
+c       endif
+	 ENDDO
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c   Ecriture du profil de temperature dans un fichier profile.out
+c   -------------------------------------------------------------
+
+
+      OPEN(12,file='profile.out',form='formatted')
+	  DO il=1,nlev
+	    write(12,*) temp(il)
+	  ENDDO
+      CLOSE(12)
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/readtesassim.F90
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/readtesassim.F90	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/readtesassim.F90	(revision 57)
@@ -0,0 +1,264 @@
+subroutine readtesassim(ngrid,nlayer,zday,pplev,tauref)
+
+! Reading of the dust assimilation file
+
+implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comgeomfi.h"
+#include "netcdf.inc"
+#include "datafile.h"
+
+integer, intent(in) :: ngrid,nlayer
+real, intent(in) :: zday ! date in martian days
+real, dimension(ngrid,nlayer+1), intent(in) :: pplev
+real, dimension(ngrid), intent(out) :: tauref
+
+! Local variables
+
+real :: realday
+integer nid,nvarid,ierr
+integer ltloop,lsloop,iloop,jloop,varloop,ig
+real, dimension(2) :: taubuf
+real tau1(4),tau
+real alt(4)
+integer latp(4),lonp(4)
+integer yinf,ysup,xinf,xsup,tinf,tsup
+real latinf,latsup,loninf,lonsup
+real latintmp,lonintmp,latdeg,londeg
+real colat,dlat,dlon,colattmp
+logical, save :: firstcall=.true.
+logical :: timeflag
+real radeg,pi
+integer :: timedim,londim,latdim
+real, dimension(:), allocatable, save :: lat,lon,time
+real, dimension(:,:,:), allocatable, save :: tautes
+integer, save :: timelen,lonlen,latlen
+INTEGER, external:: lnblnk
+
+pi=acos(-1.)
+radeg=180/pi
+realday=mod(zday,669.)
+
+if (firstcall) then
+   firstcall=.false.
+
+   ! Note: datafile() is defined in "datafile.h"
+   ierr=NF_OPEN (datafile(1:lnblnk(datafile))//"/dust_tes.nc",NF_NOWRITE,nid)
+   IF (ierr.NE.NF_NOERR) THEN
+     write(*,*)'Problem opening dust.nc (in phymars/readtesassim.F90)'
+     write(*,*)'It should be in :',datafile(1:lnblnk(datafile)),'/'
+     write(*,*)'1) You can change this directory address in '
+     write(*,*)'   file phymars/datafile.h'
+     write(*,*)'2) If necessary, dust.nc (and other datafiles)'
+     write(*,*)'   can be obtained online on:'
+     write(*,*)'   http://www.lmd.jussieu.fr/~forget/datagcm/datafile'
+     CALL ABORT
+   ENDIF
+
+   ierr=NF_INQ_DIMID(nid,"Time",timedim)
+   ierr=NF_INQ_DIMLEN(nid,timedim,timelen)
+   ierr=NF_INQ_DIMID(nid,"latitude",latdim)
+   ierr=NF_INQ_DIMLEN(nid,latdim,latlen)
+   ierr=NF_INQ_DIMID(nid,"longitude",londim)
+   ierr=NF_INQ_DIMLEN(nid,londim,lonlen)
+
+   allocate(tautes(lonlen,latlen,timelen))
+   allocate(lat(latlen), lon(lonlen), time(timelen))
+
+   ierr = NF_INQ_VARID (nid, "dustop",nvarid)
+#ifdef NC_DOUBLE
+   ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tautes)
+#else
+   ierr = NF_GET_VAR_REAL(nid, nvarid, tautes)
+#endif
+   IF (ierr .NE. NF_NOERR) THEN
+      PRINT*, "Error: Readtesassim <dustop> not found"
+      stop
+   ENDIF
+   ierr = NF_INQ_VARID (nid, "Time",nvarid)
+#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*, "Error: Readtesassim <Time> not found"
+      stop
+   ENDIF
+
+   ierr = NF_INQ_VARID (nid, "latitude",nvarid)
+#ifdef NC_DOUBLE
+   ierr = NF_GET_VAR_DOUBLE(nid, nvarid, lat)
+#else
+   ierr = NF_GET_VAR_REAL(nid, nvarid, lat)
+#endif
+   IF (ierr .NE. NF_NOERR) THEN
+      PRINT*, "Error: Readtesassim <latitude> not found"
+      stop
+   ENDIF
+
+   ierr = NF_INQ_VARID (nid, "longitude",nvarid)
+#ifdef NC_DOUBLE
+   ierr = NF_GET_VAR_DOUBLE(nid, nvarid, lon)
+#else
+   ierr = NF_GET_VAR_REAL(nid, nvarid, lon)
+#endif
+   IF (ierr .NE. NF_NOERR) THEN
+      PRINT*, "Error: Readtesassim <longitude> not found"
+      stop
+   ENDIF
+
+endif ! of if (firstcall)
+
+do ig=1,ngrid
+
+! Find the four nearest points, arranged as follows:
+!                               1 2
+!                               3 4
+
+   latdeg=lati(ig)*radeg  ! latitude, in degrees
+   londeg=long(ig)*radeg  ! longitude, in degrees east
+   colat=90-latdeg        ! colatitude, in degrees
+
+ ! Find encompassing latitudes
+   if (colat<(90-lat(1))) then ! between north pole and lat(1)
+      ysup=1
+      yinf=1
+   else if (colat>=90-(lat(latlen))) then ! between south pole and lat(laten)
+      ysup=latlen
+      yinf=latlen
+   else ! general case
+      do iloop=2,latlen
+         if(colat<(90-lat(iloop))) then
+           ysup=iloop-1
+           yinf=iloop
+           exit
+         endif
+      enddo
+   endif
+
+   latinf=lat(yinf)
+   latsup=lat(ysup)
+
+
+ ! Find encompassing longitudes
+   ! Note: in input file, lon(1)=-180.
+   if (londeg>lon(lonlen)) then
+      xsup=1
+      xinf=lonlen
+      loninf=lon(xsup)
+      lonsup=180.0 ! since lon(1)=-180.0
+   else
+      do iloop=2,lonlen
+         if(londeg<lon(iloop)) then
+              xsup=iloop
+              xinf=iloop-1
+              exit
+         endif
+      enddo
+      loninf=lon(xinf)
+      lonsup=lon(xsup)
+   endif
+
+   if ((xsup.gt.lonlen).OR.(yinf.gt.latlen).OR.(xinf.lt.1)&
+     .OR.(ysup.lt.1)) then
+      write (*,*) "Readtesassim: SYSTEM ERROR on x or y in ts_gcm"
+      write (*,*) "xinf: ",xinf
+      write (*,*) "xsup: ",xsup
+      write (*,*) "yinf: ",yinf
+      write (*,*) "ysup: ",ysup
+      stop
+   endif
+
+!   loninf=lon(xinf)
+!   lonsup=lon(xsup)
+!   latinf=lat(yinf)
+!   latsup=lat(ysup)
+
+! The four neighbouring points are arranged as follows:
+!                               1 2
+!                               3 4
+
+   latp(1)=ysup
+   latp(2)=ysup
+   latp(3)=yinf
+   latp(4)=yinf
+
+   lonp(1)=xinf
+   lonp(2)=xsup
+   lonp(3)=xinf
+   lonp(4)=xsup
+
+! Linear interpolation on time, for all four neighbouring points
+
+   if ((realday<time(1)).or.(realday>time(timelen))) then
+      tinf=timelen
+      tsup=1
+      timeflag=.true.
+   else 
+      do iloop=2,timelen
+         if (realday<time(iloop)) then
+            tinf=iloop-1
+            tsup=iloop
+            exit
+         endif
+      enddo
+   endif
+
+! Bilinear interpolation on the four nearest points
+
+   if ((colat<(90-lat(1))).OR.(colat>(90-lat(latlen))).OR.(latsup==latinf)) then
+      dlat=0
+   else
+      dlat=((90-latinf)-colat)/((90-latinf)-(90-latsup))
+   endif
+
+   if (lonsup==loninf) then
+      dlon=0
+   else
+      dlon=(londeg-loninf)/(lonsup-loninf)
+   endif
+
+   do iloop=1,4
+      taubuf(1)=tautes(lonp(iloop),latp(iloop),tinf)
+      taubuf(2)=tautes(lonp(iloop),latp(iloop),tsup)
+      if (timeflag) then
+         if (realday>time(timelen)) then
+            tau1(iloop)=taubuf(1)+(taubuf(2)-taubuf(1))*(realday-time(tinf))/(time(tsup)+(669-time(tinf))) 
+         else
+            tau1(iloop)=taubuf(1)+(taubuf(2)-taubuf(1))*realday/(time(tsup)+(669-time(tinf)))
+         endif
+      else
+         tau1(iloop)=taubuf(1)+(taubuf(2)-taubuf(1))*(realday-time(tinf))/(time(tsup)-time(tinf))
+      endif
+      if (tau1(iloop)<0) then
+          write (*,*) "Readtesassim: SYSTEM ERROR on tau"
+          write (*,*) "utime ",realday
+          write (*,*) "time(tinf) ",time(tinf)
+          write (*,*) "time(tsup) ",time(tsup)
+          write (*,*) "tau1 ",taubuf(1)
+          write (*,*) "tau2 ",taubuf(2)
+          write (*,*) "tau ",tau1(iloop)
+          stop
+      endif
+   enddo
+   timeflag=.false.
+
+   if ((dlat>1).OR.(dlon>1) .OR. (dlat<0) .OR. (dlon<0)) then
+      write (*,*) "Readtesassim: SYSTEM ERROR on dlat or dlon in ts_gcm"
+      write (*,*) "dlat: ",dlat
+      write (*,*) "lat: ",latdeg
+      write (*,*) "dlon: ",dlon
+      write (*,*) "lon: ",londeg
+      stop
+   endif
+
+   tau= dlat*(dlon*(tau1(2)+tau1(3)-tau1(1)-tau1(4))+tau1(1)-tau1(3)) +dlon*(tau1(4)-tau1(3))+tau1(3)
+
+!   tauref(ig)=tau*700/pplev(ig,1)*0.8
+    tauref(ig)=tau*0.825
+enddo
+
+end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scatter.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scatter.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scatter.F	(revision 57)
@@ -0,0 +1,21 @@
+       subroutine scatter(n,a,index,b)
+C
+       implicit none
+       integer N,INDEX(n),I
+       real A(n),B(n)
+c
+c
+       DO 100 I=1,N
+          A(INDEX(I))=B(I)
+100    CONTINUE
+c
+       return
+       end 
+c
+c
+c      peut etre vec_scatter(v,rindices,count,r) en f77hp
+c      equivalent code:
+c      do 99 i=1,count
+c99    r(rindices(i))=v(i)
+c      voir p. 11-13
+c
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scopyi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scopyi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/scopyi.F	(revision 57)
@@ -0,0 +1,17 @@
+      subroutine scopyi(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      integer sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+      sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/soil.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/soil.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/soil.F	(revision 57)
@@ -0,0 +1,192 @@
+      SUBROUTINE soil(ngrid,nsoil,firstcall,ptherm_i,
+     s          ptimestep,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   ngird               number of grid-points
+c   ptimestep              physical timestep (s)
+c   pto(ngrid,nsoil)     temperature at time-step t (K)
+c   ptn(ngrid,nsoil)     temperature at time step t+dt (K)
+c   pcapcal(ngrid)      specific heat (W*m-2*s*K-1)
+c   pfluxgrd(ngrid)      surface diffusive flux from ground (Wm-2)
+c   
+c=======================================================================
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+
+c-----------------------------------------------------------------------
+c  arguments
+c  ---------
+
+      INTEGER ngrid,nsoil
+      REAL ptimestep
+      REAL ptsrf(ngridmx),ptsoil(ngrid,nsoilmx),ptherm_i(ngridmx)
+      REAL pcapcal(ngrid),pfluxgrd(ngrid)
+      LOGICAL firstcall
+
+c-----------------------------------------------------------------------
+c  local arrays
+c  ------------
+
+      INTEGER ig,jk
+      REAL za(ngridmx),zb(ngridmx)
+      REAL zdz2(nsoilmx),z1(ngridmx)
+      REAL min_period,dalph_soil
+
+c   local saved variables:
+c   ----------------------
+      REAL dz1(nsoilmx),dz2(nsoilmx)
+      REAL zc(ngridmx,nsoilmx),zd(ngridmx,nsoilmx)
+      REAL lambda
+      SAVE dz1,dz2,zc,zd,lambda
+
+c-----------------------------------------------------------------------
+c   Depthts:
+c   --------
+
+      REAL fz,rk,fz1,rk1,rk2
+      fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+
+      IF (firstcall) THEN
+
+c-----------------------------------------------------------------------
+c   ground levels 
+c   grnd=z/l where l is the skin depth of the diurnal cycle:
+c   --------------------------------------------------------
+
+         min_period=887.75
+c        min_period=1800.
+c        min_period=20000.
+         dalph_soil=2.
+
+         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,nsoil
+            rk1=jk
+            rk2=jk-1
+            dz2(jk)=fz(rk1)-fz(rk2)
+         ENDDO
+         DO jk=1,nsoil-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 (secoonds)'
+         DO jk=1,nsoil
+            rk=jk
+            rk1=jk+.5
+            rk2=jk-.5
+            PRINT*,fz(rk1)*fz(rk2)*3.14,
+     s      fz(rk)*fz(rk)*3.14
+         ENDDO
+
+c   Initialisations:
+c   ----------------
+
+      ELSE
+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,ngrid
+            ptsoil(ig,1)=(lambda*zc(ig,1)+ptsrf(ig))/
+     s      (lambda*(1.-zd(ig,1))+1.)
+         ENDDO
+
+c   other temperatures
+         DO jk=1,nsoil-1
+            DO ig=1,ngrid
+               ptsoil(ig,jk+1)=zc(ig,jk)+zd(ig,jk)*ptsoil(ig,jk)
+            ENDDO
+         ENDDO
+
+      ENDIF
+c-----------------------------------------------------------------------
+c   Computation of the Cgrd and Dgrd coefficient for the next step:
+c   ---------------------------------------------------------------
+
+      DO jk=1,nsoil
+         zdz2(jk)=dz2(jk)/ptimestep
+      ENDDO
+
+      DO ig=1,ngrid
+         z1(ig)=zdz2(nsoil)+dz1(nsoil-1)
+         zc(ig,nsoil-1)=zdz2(nsoil)*ptsoil(ig,nsoil)/z1(ig)
+         zd(ig,nsoil-1)=dz1(nsoil-1)/z1(ig)
+      ENDDO
+
+      DO jk=nsoil-1,2,-1
+         DO ig=1,ngrid
+            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,ngrid
+         pfluxgrd(ig)=ptherm_i(ig)*dz1(1)*
+     s   (zc(ig,1)+(zd(ig,1)-1.)*ptsoil(ig,1))
+         pcapcal(ig)=ptherm_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: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solang.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solang.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solang.F	(revision 57)
@@ -0,0 +1,114 @@
+      subroutine solang ( kgrid,psilon,pcolon,psilat,pcolat,
+     &                    ptim1,ptim2,ptim3,pmu0,pfract )
+      IMPLICIT NONE
+
+C
+C**** *LW*   - ORGANIZES THE LONGWAVE CALCULATIONS
+C
+C     PURPOSE.
+C     --------
+C          CALCULATES THE SOLAR ANGLE FOR ALL THE POINTS OF THE GRID
+C
+C**   INTERFACE.
+C     ----------
+C      SUBROUTINE SOLANG ( KGRID )
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS  ===
+C
+C PSILON(KGRID)   : SINUS OF THE LONGITUDE
+C PCOLON(KGRID)   : COSINUS OF THE LONGITUDE
+C PSILAT(KGRID)   : SINUS OF THE LATITUDE
+C PCOLAT(KGRID)   : COSINUS OF THE LATITUDE
+C PTIM1           : SIN(DECLI)
+C PTIM2           : COS(DECLI)*COS(TIME)
+C PTIM3           : SIN(DECLI)*SIN(TIME)
+C
+C     ==== OUTPUTS ===
+C
+C PMU0 (KGRID)    : SOLAR ANGLE
+C PFRACT(KGRID)   : DAY FRACTION OF THE TIME INTERVAL
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C     EXTERNALS.
+C     ----------
+C
+C         NONE
+C
+C     REFERENCE.
+C     ----------
+C
+C         RADIATIVE PROCESSES IN METEOROLOGIE AND CLIMATOLOGIE
+C         PALTRIDGE AND PLATT
+C
+C     AUTHOR.
+C     -------
+C        FREDERIC HOURDIN
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL :90-01-14
+C                  92-02-14 CALCULATIONS DONE THE ENTIER GRID (J.Polcher)
+C-----------------------------------------------------------------------
+C
+C     ------------------------------------------------------------------
+
+C-----------------------------------------------------------------------
+C
+C*      0.1   ARGUMENTS
+C             ---------
+C
+      INTEGER kgrid
+      REAL ptim1,ptim2,ptim3
+      REAL psilon(kgrid),pcolon(kgrid),pmu0(kgrid),pfract(kgrid)
+      REAL psilat(kgrid), pcolat(kgrid)
+C
+      INTEGER jl
+      REAL ztim1,ztim2,ztim3
+C------------------------------------------------------------------------
+C------------------------------------------------------------------------
+C------------------------------------------------------------------------
+C
+C------------------------------------------------------------------------
+C
+C*     1.     INITIALISATION
+C             --------------
+C
+ 100  CONTINUE
+C
+      DO jl=1,kgrid
+        pmu0(jl)=0.
+        pfract(jl)=0.
+      ENDDO
+C
+C*     1.1     COMPUTATION OF THE SOLAR ANGLE
+C              ------------------------------
+C
+      DO jl=1,kgrid
+        ztim1=psilat(jl)*ptim1
+        ztim2=pcolat(jl)*ptim2
+        ztim3=pcolat(jl)*ptim3
+        pmu0(jl)=ztim1+ztim2*pcolon(jl)+ztim3*psilon(jl)
+      ENDDO
+C
+C*     1.2      DISTINCTION BETWEEN DAY AND NIGHT
+C               ---------------------------------
+C
+      DO jl=1,kgrid
+        IF (pmu0(jl).gt.0.) THEN
+          pfract(jl)=1.
+c       pmu0(jl)=sqrt(1224.*pmu0(jl)*pmu0(jl)+1.)/35.
+      ELSE
+c       pmu0(jl)=0.
+        pfract(jl)=0.
+        ENDIF
+      ENDDO
+C
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solarlong.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solarlong.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/solarlong.F	(revision 57)
@@ -0,0 +1,107 @@
+      SUBROUTINE solarlong(pday,psollong)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Objet:
+c   ------
+c
+c      Calcul de la distance soleil-planete et de la declinaison
+c   en fonction du jour de l'annee.
+c
+c
+c   Methode:
+c   --------
+c
+c      Calcul complet de l'elipse
+c
+c   Interface:
+c   ----------
+c
+c      Uncommon comprenant les parametres orbitaux.
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
+c   lwrite        clef logique pour sorties de controle
+c
+c   Output:
+c   -------
+c   pdist_sol     distance entre le soleil et la planete
+c                 ( en unite astronomique pour utiliser la constante 
+c                  solaire terrestre 1370 Wm-2 )
+c   pdecli        declinaison ( en radians )
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "comcstfi.h"
+
+c arguments:
+c ----------
+
+      REAL pday,pdist_sol,pdecli,psollong
+      LOGICAL lwrite
+
+c Local:
+c ------
+
+      REAL zanom,xref,zx0,zdx,zteta,zz
+      INTEGER iter
+
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c   Initialisation eventuelle:
+      if(.not.unitastr.gt.1.e-4) then
+         call iniorbit(249.22,206.66,669.,485.,25.2)
+      endif
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(pday-peri_day)/year_day
+      pi=2.*asin(1.)
+      zanom=2.*pi*(zz-nint(zz))
+      xref=abs(zanom)
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
+c  methode de Newton
+
+      zx0=xref+e_elips*sin(xref)
+      DO 110 iter=1,10
+         zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
+         if(abs(zdx).le.(1.e-7)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+
+c zteta est la longitude solaire
+
+      zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+
+      psollong=zteta-timeperi
+
+      IF(psollong.LT.0.) psollong=psollong+2.*pi
+      IF(psollong.GT.2.*pi) psollong=psollong-2.*pi
+c-----------------------------------------------------------------------
+c   sorties eventuelles:
+c   ---------------------
+
+c     IF (lwrite) THEN
+c        PRINT*,'jour de l"annee   :',pday
+c        PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol
+c        PRINT*,'declinaison (en degres) :',pdecli*180./pi
+c     ENDIF
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/statto.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/statto.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/statto.h	(revision 57)
@@ -0,0 +1,34 @@
+
+!  statto:
+!     This include file controls the production of statistics.
+!     Some variables could be set in a namelist, but it is easier to
+!     do it here since arrays can then be dimensioned using parameters
+!     and values shouldn't have to change too often.   SRL
+
+!     Calculate stats every istats physics timesteps, starting at first
+!     call.  If istats=0 then don't do statistics at all.  Check value
+!     if number of physics timesteps changes.
+	integer istats
+
+!     Calculate itime independent sums and sums of squares,
+!     example, istat=1,istime=1 gives a single time mean
+	integer, parameter :: istime=12
+
+!     Number of 2D and 3D variables on which to do statistics.
+	integer n2dvar, n3dvar
+	parameter (n2dvar = 8, n3dvar = 5)
+
+!     Units for writing stats header and data
+	integer usdata
+
+!     count tab to know the variable record
+        integer count(istime)
+
+!     Record of the number of stores made for each time.
+	integer nstore(istime)
+
+! Size of the "controle" array
+        integer, parameter :: cntrlsize=15
+
+!       common /sttcom/ dummy,nstore,istats,usdata
+        common /sttcom/ nstore,istats,usdata,count
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/suaer.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/suaer.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/suaer.F	(revision 57)
@@ -0,0 +1,269 @@
+      SUBROUTINE SUAER
+      implicit none
+C     
+C     Purpose.
+C     --------
+C     initialize yomaer, the common that contains the
+C     radiative characteristics of the aerosols
+c     
+C     AUTHOR.
+C     -------
+c     Richard Fournier (1996) Francois Forget (1996)
+c     Frederic Hourdin
+C     Jean-jacques morcrette *ECMWF*
+c     MODIF Francois Forget (2000)
+c     MODIF Franck Montmessin (add water ice)
+C     ------------------------------------------------------------------
+C     
+C-----------------------------------------------------------------------
+C     
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "yomaer.h"
+     
+c     Aerosol Spectral properties :
+#include "aerdust.h"
+
+#ifdef ICE
+#include "aerice.h"
+#endif
+C-----------------------------------------------------------------------
+c     
+      INTEGER iaer,isun,iir,n
+
+c I/O  of "aerave" (subroutine averaging spectrally sing.scat.parameters) 
+      REAL tsun             ! Sun brightness temperature (for SW)
+      REAL tsol             ! Surface reference brightness temp (for LW)
+      REAL longref          ! reference wavelengths
+      REAL longsun(nsun+1)  ! solar band boundaries
+      REAL longir(nir+1)    ! IR band boundaries
+      REAL epref            ! reference extinction ep at wavelength "longref"
+      REAL epav(nir)        ! average ep  (= <Qext>/Qext(longref) if epref=1)
+      REAL omegav(nir)      ! Average sing.scat.albedo
+      REAL gav(nir)         ! Average assymetry parameter
+      REAL QIRTM9sQrefIR    ![Qext averaged over IRTM 9um band]/Qext(longrefir)
+                            ! with longrefir defined in dimradmars.h 
+
+
+C-----------------------------------------------------------------------
+c     quelques initialisations a 0
+      call zerophys(naerkind*nsun,gvis)
+      call zerophys(naerkind*nsun,omegavis)
+      call zerophys(naerkind*nsun,QVISsQREF)
+
+      call zerophys(naerkind*nir,gIR)
+      call zerophys(naerkind*nir,omegaIR)
+      call zerophys(naerkind*nir,QIRsQREF)
+c     
+C-----------------------------------------------------------------------
+C     
+C     ----------------------------------------------------------------
+C     *       1.    SHORTWAVE COEFFICIENTS
+C     ----------------------------------------------------------------
+C     
+c     Computing average optical properties on both solar bands
+c     For pure dust (naerkind=1)
+c     
+      do iaer=1,naerkind
+
+      tsun=6000.E+0
+      longsun(1)=long1vis
+      longsun(2)=long2vis
+      longsun(3)=long3vis
+      longref=longrefvis
+      epref=1.E+0         
+
+
+c     Here, epav is <Qext>/Qext(longrefvis) since epref=1 :
+
+      if (iaer.eq.1) then
+      CALL aerave ( ndustvis,
+     &     longdustvis,epdustvis,omegdustvis,gdustvis,
+     &     longref,epref,tsun
+     &     ,nsun,longsun, epav,omegav,gav )
+      elseif (iaer.eq.2) then
+#ifdef ICE
+      CALL aerave ( nicevis,
+     &     longicevis,epicevis,omegicevis,gicevis,
+     &     longref,epref,tsun
+     &     ,nsun,longsun, epav,omegav,gav )
+#endif
+      endif
+
+       do isun=1,nsun
+            QVISsQREF(isun,iaer)=epav(isun)
+            gvis(isun,iaer)=gav(isun)
+            omegavis(isun,iaer)=omegav(isun)
+c TEST
+c	    if (iaer.eq.2)  omegavis(isun,iaer)=.86   
+c	    if (iaer.eq.2)  gvis(isun,iaer)=-1.  
+c	    if (iaer.eq.2) then   !TEST
+c              QVISsQREF(isun,iaer)=QVISsQREF(isun,1)
+c              gvis(isun,iaer)=gvis(isun,1)
+c              omegavis(isun,iaer)=omegavis(isun,1)
+c            endif
+c END TEST
+
+       enddo
+
+c     
+
+C     ----------------------------------------------------------------
+C     *       2.    LONGWAVE COEFFICIENTS
+C     ----------------------------------------------------------------
+
+      if (iaer.eq.1) then
+
+c     Computing average optical properties on both solar bands
+c     For dust (iaer=1)
+c
+c     Calcul preliminaire
+c     ~~~~~~~~~~~~~~~~~~~
+c     Ratio betwen Qext averaged over IRTM 9um band
+c     and Qext(longrefir) (longrefir is defined in dimradmars.h)
+c     -> useful because the ratio of extinction "solsir"
+c      is defined between 0.67um and the IRTM 9um band 
+c      (for which it has been estimated)
+
+      tsol=215.D+0
+c     IRTM band (T9):
+      longir(1)=8.3E-6
+      longir(2)=9.7E-6
+      longref=longrefir
+      epref=1.E+0
+
+c     Here, epav is QavIRTM9/Qext(longrefir) since epref=1 :
+
+       write(*,*) 'Call test 9 micron'
+      CALL aerave ( ndustir,
+     &     longdustir,epdustir,omegdustir,gdustir,
+     &     longref,epref,tsol
+     &     ,1,longir,epav,omegav,gav )
+       write(*,*) 'OK test 9 micron'
+      QIRTM9sQrefIR=epav(1)
+      
+c     Average scaterring properties of 3 IR bands defined as :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     [long1ir - long1co2] , [long1co2-long2co2], [long2co2 - long2ir]
+c
+
+      tsol=215.D+0
+      longir(1)=long1ir
+      longir(2)=long1co2
+      longir(3)=long2co2
+      longir(4)=long2ir
+      longref=longrefir
+      epref=1.E+0
+
+c     Here, epav is <QIR>/Qext(longrefir) since epref=1
+      CALL aerave ( ndustir,
+     &     longdustir,epdustir,omegdustir,gdustir,
+     &     longref,epref,tsol
+     &     ,nir-1,longir,epav,omegav,gav )
+
+c     Computing  <QIR>/Qext(longrefvis)
+      DO iir=1,4
+         epav(iir)=  epav(iir) / (QIRTM9sQrefIR * solsir)
+      ENDDO
+
+      elseif (iaer.eq.2) then
+
+c     Average scaterring properties of 3 IR bands defined as :
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c     [long1ir - long1co2] , [long1co2-long2co2], [long2co2 - long2ir]
+c
+
+      tsol=215.D+0
+      longir(1)=long1ir
+      longir(2)=long1co2
+      longir(3)=long2co2
+      longir(4)=long2ir
+      longref=longrefir
+      epref=1.E+0
+
+c     Here, epav is <QIR>/Qext(longrefir) since epref=1
+#ifdef ICE
+      CALL aerave ( niceir,
+     &     longiceir,epiceir,omegiceir,giceir,
+     &     longref,epref,tsol
+     &     ,nir-1,longir,epav,omegav,gav )
+
+c     Computing  <QIR>/Qext(longrefvis)
+      DO iir=1,4
+         epav(iir)=  epav(iir) / solsirice
+      ENDDO
+#endif
+
+      endif
+c  Single scattering properties in each of the "nir" bands (cf. dimramars.h)
+c  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c  iir=1 : central 15um CO2 bands   
+      QIRsQREF(1,iaer)=epav(2)
+      omegaIR(1,iaer)=omegav(2)
+      gIR(1,iaer)=gav(2)
+
+c  iir=2 : CO2 band wings (same properties than for central part)
+      QIRsQREF(2,iaer)=epav(2)
+      omegaIR(2,iaer)=omegav(2)
+      gIR(2,iaer)=gav(2)
+
+c  iir=3 : 9 um band [long1ir - long1co2]
+      QIRsQREF(3,iaer)=epav(1)
+      omegaIR(3,iaer)=omegav(1)
+      gIR(3,iaer)=gav(1)
+
+c  iir=4 : Far IR    [long2co2 - long2ir]
+      QIRsQREF(4,iaer)=epav(3)
+      omegaIR(4,iaer)=omegav(3)
+      gIR(4,iaer)=gav(3)
+
+c      if (iaer.eq.2) then  !TEST
+c	do iir=1,4
+c	  QIRsQREF(iir,iaer)=QIRsQREF(iir,1)
+c          omegaIR(iir,iaer)= omegaIR(iir,1)
+c          gIR(iir,iaer)=gIR(iir,1)
+c        enddo
+c      endif
+
+C     ----------------------------------------------------------------
+C     Output on screen 
+C     ----------------------------------------------------------------
+      if (iaer.eq.1) then
+        PRINT*,'PURE DUST PROPERTIES :'
+        PRINT*
+        PRINT*,'Rapport Solaire/IR :',solsir
+        PRINT*
+      elseif (iaer.eq.2) then
+#ifdef ICE
+        PRINT*,'ICE PROPERTIES :'
+        PRINT*
+        PRINT*,'Rapport Solaire/IR :',solsirice
+        PRINT*
+#endif
+      endif
+
+      PRINT *,'Les donnees spectrales :'
+      PRINT *,'Solaire (SW) ---->'
+      PRINT *,'<Qext>/Qext(0.67um) ; omega ; g'
+      DO isun=1,nsun
+         PRINT *,QVISsQREF(isun,iaer),omegavis(isun,iaer)
+     &    ,gvis(isun,iaer)
+      ENDDO
+      PRINT *,'Thermal IR (LW) ---->'
+      PRINT *,'<Qext>/Qext(0.67um) ; omega ; g'
+      DO iir=1,nir
+         PRINT *,QIRsQREF(iir,iaer),omegaIR(iir,iaer),gIR(iir,iaer)
+      ENDDO
+c     
+
+      print *,'Dans le co2 on prend <Qabs>/Qext(0.67um) =',
+     &  QIRsQREF(1,iaer)*(1-omegaIR(1,iaer))  
+      write(*,*)
+
+      enddo  ! Loop on iaer
+      
+
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sugwd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sugwd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sugwd.F	(revision 57)
@@ -0,0 +1,109 @@
+      SUBROUTINE SUGWD(NLEV,PSIG)
+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     EXPLICIT ARGUMENTS :
+C     --------------------
+C     
+C     INPUT :
+C     
+C     PSIG        : VERTICAL COORDINATE TABLE
+C     NLEV        : NUMBER OF MODEL LEVELS
+C     
+C     OUTPUT :
+C     
+C     NONE
+C     
+C     IMPLICIT ARGUMENTS :
+C     --------------------
+C     COMMON YOEGWD
+C     
+C     METHOD.
+C     -------
+C     SEE DOCUMENTATION
+C     
+C     EXTERNALS.
+C     ----------
+C     NONE
+C     
+C     REFERENCE.
+C     ----------
+C     ECMWF Research Department documentation of the IFS
+C     
+C     AUTHOR.
+C     -------
+C     MARTIN MILLER             *ECMWF*
+C     
+C     MODIFICATIONS.
+C     --------------
+C     ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C     
+C     -----------------------------------------------------------------
+c     !-*-      include 'yoegwd.h'
+#include "yoegwd.h"
+c     !-*-
+C     ----------------------------------------------------------------
+C     
+      integer nlev
+      REAL PSIG(NLEV+1)
+
+      real zsigt,zpr,zpm1r
+      integer jk
+C     
+C     *       1.    SET THE VALUES OF THE PARAMETERS
+C     --------------------------------
+C     
+ 100  CONTINUE
+C     
+c     PRINT *,' Dans sugwd nlev=',NLEV,' SIG=',PSIG
+      GHMAX=10000.
+C     
+c     old  ZSIGT=0.94
+c     old  ZPR=80000.
+      ZSIGT=0.85
+      ZPR=100000.
+C     
+      DO 110 JK=1,NLEV-1
+         ZPM1R=0.5*ZPR*(PSIG(JK)+PSIG(JK+1))
+         IF((ZPM1R/ZPR).GE.ZSIGT)THEN
+            NKTOPG=JK
+         ENDIF
+ 110  CONTINUE
+      WRITE(*,*) 'In sugwd NKTOPG=',NKTOPG
+C     
+      GSIGCR=0.80
+C     
+      GKDRAG= 0.1  ! used to be 0.1 for mcd Version 1 and 2 (before 10/2000)
+      GRCRIT=0.25
+      GFRCRIT=1.0
+      GKWAKE=1.0
+
+C     
+      GKDRAGL=4.*GKDRAG
+      GRAHILO=1.
+      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: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sulw.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sulw.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/sulw.F	(revision 57)
@@ -0,0 +1,81 @@
+      SUBROUTINE SULW
+C     
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+#include "yomlw.h"
+C     
+C     PURPOSE.
+C     --------
+C     INITIALIZE YOMLW, THE COMMON THAT CONTAINS COEFFICIENTS
+C     NEEDED TO RUN THE LONGWAVE RADIATION ROUTINES
+C     
+C     AUTHOR.
+C     -------
+C     JEAN-JACQUES MORCRETTE  *ECMWF*
+c     Simplified F. Forget 01/2000
+C     
+C     ------------------------------------------------------------------
+C     ----------------------------------------------------------------
+C     
+C     *       1.    SET VALUES.
+C     -----------
+C     
+C     
+C--   REFERENCE TEMPERATURES FOR THE PLANCK FUNCTIONS ----- TSTAND
+C     TEMPERATURE DEPENDENCE OF THE ABSORPTION ----- TREF
+      DATA TSTAND,TREF / 200.0, 200.0 /
+C     
+C--   ROOTS AND WEIGHTS FOR THE 2-POINT GAUSSIAN QUADRATURE
+c     DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
+c     DATA (WG1(IG1),IG1=1,2) /  1.0        ,  1.0         /
+
+c-----------------------------------------------------------------------
+C--   COEFFICIENTS OF THE POLYNOMIALS GIVING THE PLANCK FUNCTIONS
+C     
+      DATA xp/
+
+     s     0.63849788E+01, 0.30969419E+02, 0.44790835E+02,
+     s     0.52651048E+01,-0.18799237E+02, 0.92836181E+01,
+
+     s     0.26166790E+02, 0.12348011E+03, 0.17868306E+03,
+     s     0.33657659E+02,-0.66869343E+02, 0.21017507E+02,
+c     
+c     s  0.47045285E+02, 0.12234377E+03, 0.61873275E+02,
+c     s -0.31971883E+02, 0.59168472E+01, 0.91927407E+01,
+c     
+c     s  0.11101254E+02, 0.86037325E+02, 0.25892695E+03,
+c     s  0.35582991E+03, 0.16958020E+03,-0.41311413E+02/
+c     
+     s     0.11101254E+02, 0.86037325E+02, 0.25892695E+03,
+     s     0.35582991E+03, 0.16958020E+03,-0.41311413E+02,
+
+     s     0.47045285E+02, 0.12234377E+03, 0.61873275E+02,
+     s     -0.31971883E+02, 0.59168472E+01, 0.91927407E+01/
+
+c     
+c-----------------------------------------------------------------------
+c     temperature dependency of absorber amounts:
+c     -------------------------------------------
+
+      DATA at
+     s     / 0.694E-03, 0.272E-02, 0.275E-02, 0.178E-01/
+      DATA bt
+     s     / 0.328E-05, 0.298E-05,-0.705E-04,-0.163E-04/
+
+c-----------------------------------------------------------------------
+      DATA (ga(ie, 1),ie=1,4)
+     s     / 0.288231E-04, 0.170794E-01,-0.339714E-01, 0.000000E+00/
+      DATA (gb(ie, 1),ie=1,4)
+     s     / 0.288231E-04, 0.145426E-01, 0.543812E+00, 0.100000E+01/
+
+      DATA (ga(ie, 2),ie=1,4)
+     s     / 0.289299E-01, 0.190634E+01, 0.384061E+01, 0.000000E+00/
+      DATA (gb(ie, 2),ie=1,4)
+     s     / 0.289299E-01, 0.189485E+01, 0.600363E+01, 0.100000E+01/
+
+      DATA cst_voigt / 0.500E-02, 0.100E-01, 0.150E-01, 0.100E+00/
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfdat.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfdat.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfdat.h	(revision 57)
@@ -0,0 +1,9 @@
+      COMMON/surfdat/albedodat(ngridmx),inertiedat(ngridmx),
+     s   phisfi(ngridmx),albedice(2),emisice(2),emissiv,
+     s   iceradius(2) , dtemisice(2),
+     s   zmea(ngridmx),zstd(ngridmx),
+     s   zsig(ngridmx),zgam(ngridmx),zthe(ngridmx)
+
+      REAL albedodat,inertiedat,phisfi,albedice,emisice,emissiv,
+     s   iceradius , dtemisice
+      real zmea,zstd,zsig,zgam,zthe
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfini.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfini.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/surfini.F	(revision 57)
@@ -0,0 +1,67 @@
+      SUBROUTINE surfini(ngrid,piceco2,qsurf,psolaralb)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   creation des calottes pour l'etat initial
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+#include "dimensions.h"
+#include "dimphys.h"
+#include "surfdat.h"
+#include "callkeys.h"
+#include "tracer.h"
+c
+      INTEGER ngrid,ig,icap
+      REAL  piceco2(ngrid),psolaralb(ngrid,2)
+      REAL qsurf(ngrid,nqmx) !tracer on surface (kg/m2)
+
+      EXTERNAL ISMIN,ISMAX
+      INTEGER ISMIN,ISMAX
+c
+c=======================================================================
+
+c
+c     calcul de piceco2 (kg/m2) a l'etat initial
+c     ------------------------------------------
+
+      DO 100 ig=1,ngrid
+         psolaralb(ig,1)=albedodat(ig)
+         psolaralb(ig,2)=albedodat(ig)
+100   CONTINUE
+
+      PRINT*,'minimum des donnees albedo',
+     s     albedodat(ISMIN(ngrid,albedodat,1))
+      PRINT*,'maximum des donnees albedo',
+     s     albedodat(ISMAX(ngrid,albedodat,1))
+c      calcul de psolaralb 
+c      -------------------
+      DO 115 ig=1,ngrid
+
+c	 IF (water) THEN 
+c	   if (qsurf(ig,nqmx).gt.0.005) then
+c             psolaralb(ig,1) = 0.4
+c             psolaralb(ig,2) = 0.4 
+c           endif 
+c         ENDIF
+c IF there is more than 5 pr. um of h2o ice but no C02 ice, surface albedo is set to 0.4. 
+         IF (piceco2(ig) .GT. 0.) THEN
+             IF(ig.GT.ngrid/2+1) THEN
+                icap=2
+             ELSE
+                icap=1
+             ENDIF
+             psolaralb(ig,1) = albedice(icap)
+             psolaralb(ig,2) =  albedice(icap)
+         END IF
+115   CONTINUE      
+
+      PRINT*,'minimum des donnees albedo',
+     s     psolaralb(ISMIN(ngrid,psolaralb,1),1)
+      PRINT*,'maximum des donnees albedo',
+     s     psolaralb(ISMAX(ngrid,psolaralb,1),1)
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swmain.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swmain.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swmain.F	(revision 57)
@@ -0,0 +1,173 @@
+      SUBROUTINE SWMAIN ( KDLON, KFLEV,
+     $                PCST, albedo,
+     $                PRMU0, PDP, PPLEV, aerosol,PFRACT,
+     $                PHEAT, PFLUXD,PFLUXU)
+
+      IMPLICIT NONE
+      
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+
+#include "yomaer.h"
+#include "yomlw.h"
+#include "callkeys.h"
+c     
+c     PURPOSE.
+c     --------
+c     
+c     This routine computes the shortwave (solar wavelength)
+c     radiation fluxes in two spectral intervals 
+c     and heating rate on the first "nlaylte" layers.
+C     
+c     Francois Forget (2000), adapted from 
+C     Fouquart and Bonnel's ECMWF program
+c 
+C     IMPLICIT ARGUMENTS :
+C     --------------------
+C     
+C     ==== INPUTS ===
+c
+c    KDLON :  number of horizontal grid points
+c    PCST  :  Solar constant on Mars (W.m-2)
+c    albedo   hemispheric surface albedo
+c                         albedo (i,1) : mean albedo for solar band#1
+c                                        (see below)
+c                         albedo (i,2) : mean albedo for solar band#2
+c                                        (see below)
+c    PRMU0 :         cos of solar zenith angle (=1 when sun at zenith)
+c    PDP :           Layer thickness (Pa)
+c    PPLEV           pressure (Pa) at boundaries of each layer 
+c   aerosol               aerosol extinction optical depth
+c                         at reference wavelength "longrefvis" set
+c                         in dimradmars.h , in each layer, for one of
+c                         the "naerkind" kind of aerosol optical properties.
+c    Pfract :        day fraction of the time interval
+c                          =1 during the full day ; =0 during the night
+C     ==== OUTPUTS ===
+c    PHEAT :         Heating rate (K/s)
+c    PFLUXD :        SW downward flux at boundaries of each layer (W.m-2)
+c    PFLUXU :        SW upward flux at boundaries of each layer (W.m-2)
+C     
+C     ----------
+C     
+C-----------------------------------------------------------------------
+C     
+C     
+C-----------------------------------------------------------------------
+C     
+C     ARGUMENTS
+C     ---------
+      
+      INTEGER KDLON, KFLEV
+      REAL ZPSOL(NDLO2), aerosol(NDLO2,KFLEV,naerkind),PRMU0(NDLO2)
+      real PCST
+      REAL albedo(NDLO2,2)
+      REAL PDP(NDLO2,KFLEV)
+      REAL PPLEV(NDLO2,KFLEV+1)
+      REAL PHEAT(NDLO2,KFLEV)
+      REAL PFRACT(NDLO2)
+      real PFLUXD(NDLON,NFLEV+1,2)
+      real PFLUXU(NDLON,NFLEV+1,2)
+      
+C     LOCAL ARRAYS
+C     ------------
+      
+      REAL ZDSIG(NDLON,NFLEV), ZFACT(NDLON)
+     S     ,  ZFD(NDLON,NFLEV+1)
+     S     ,  ZFU(NDLON,NFLEV+1)
+     S     ,  ZRMU(NDLON), ZSEC(NDLON)
+     S     ,  ZUD(NDLON,3,NFLEV+1), ZUM(NDLON,NFLEV+1)
+      REAL ZSIGN(NDLON),  ZSIGO(NDLON)
+
+c following line has been changed, kflev--->nflev (to avoid error message 
+c when compiling on NASA Ames Sun)
+      REAL ZFDOWN(NDLO2,NFLEV+1),ZFUP(NDLO2,NFLEV+1)
+
+      integer jl, jk, jkp1, jkl
+      integer INU 
+      real  zdfnet
+
+C     ------------------------------------------------------------------
+C     Initializations :
+C     ------------------------------------------------------------------
+
+c     Incident Solar flux and corrected angle in the atmosphere 
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      DO JL = 1 , KDLON
+c        Incident Flux at the top of the atmosphere
+         ZFACT(JL)= PRMU0(JL) * PCST * PFRACT(JL)
+
+c        Cos of solar zenith angle CORRECTED for high zenith angle
+       if (PRMU0(JL).GT.0) then
+         ZRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+       else
+         ZRMU(JL)= 1. / 35.
+       endif
+         ZSEC(JL)=1./ZRMU(JL)
+      END DO
+
+c     Calcul of ZDSIG  (thickness of layers in sigma coordinates)
+c     ~~~~~~~~~~~~~~~
+      DO JL = 1 , KDLON
+         ZSIGO(JL) = 1.0
+         ZPSOL(JL) = PPLEV(JL,1)
+      END DO
+      DO JK = 1 , nlaylte
+         JKP1 = JK + 1
+         JKL = nlaylte+1 - JK
+         DO  JL = 1 , KDLON
+            ZSIGN(JL) = PPLEV(JL,JKP1) / PPLEV(JL,1)
+            ZDSIG(JL,JK) = ZSIGO(JL) - ZSIGN(JL)
+            ZSIGO(JL) = ZSIGN(JL)
+         END DO
+      END DO
+
+C------------------------------------------------------------------
+C          LOOP ON SPECTRAL INTERVAL in solar spectrum
+C------------------------------------------------------------------
+c  2 spectral interval in solar spectrum :
+c  - INU=1: between wavelength "long1vis" and "long2vis" set in dimradmars.h
+c  - INU=2: between wavelength "long2vis" and "long3vis" set in dimradmars.h
+
+      DO INU = 1,2
+         CALL SWR ( KDLON, kflev, INU
+     S     ,  aerosol,albedo,ZDSIG,ZPSOL,ZRMU,ZSEC
+     S     ,  ZFD,ZFU )
+
+         DO JK = 1 , nlaylte+1
+            DO  JL = 1 , KDLON
+              PFLUXD(JL,JK,INU)=ZFD(JL,JK)*ZFACT(JL)
+              PFLUXU(JL,JK,INU)=ZFU(JL,JK)*ZFACT(JL)
+            END DO
+         END DO
+      END DO
+
+C     ------------------------------------------------------
+C     HEATING RATES
+C     ------------------------------------------------------
+
+      DO JK = 1 , nlaylte+1
+         DO  JL = 1 , KDLON
+c           wavelength integrated flux at every level:
+            ZFUP(JL,JK)= (PFLUXU(JL,JK,1)+ PFLUXU(JL,JK,2))
+            ZFDOWN(JL,JK)= (PFLUXD(JL,JK,1)+ PFLUXD(JL,JK,2))
+         END DO
+      END DO
+     
+      DO JK = 1 , nlaylte
+         DO  JL = 1 , KDLON
+            ZDFNET = ZFUP (JL,JK  ) - ZFDOWN(JL,JK  )
+     S              -ZFUP (JL,JK+1) + ZFDOWN(JL,JK+1)
+c           Heating rate
+            PHEAT(JL,JK) = gcp * ZDFNET / PDP(JL,JK)
+c TEST pour diminuer erreur eddington pour diffuseurs simples	    
+c           if (activice) then   
+c	    if(aerosol(JL,JK,2)/aerosol(JL,JK,1).gt.1) 
+c     s 	    PHEAT(JL,JK) =PHEAT(JL,JK)/10.
+c           endif 
+         END DO
+      END DO
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swr.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swr.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swr.F	(revision 57)
@@ -0,0 +1,380 @@
+      SUBROUTINE SWR ( KDLON, KFLEV, KNU
+     S     ,  aerosol,albedo,PDSIG,PPSOL,PRMU,PSEC
+     S     ,  PFD,PFU )
+
+      IMPLICIT NONE
+C     
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "callkeys.h"
+
+#include "yomaer.h"
+#include "yomlw.h"
+
+#include "fisice.h"
+
+#include "aerice.h"
+C     
+C   SWR - Continuum scattering computations
+C     
+C     PURPOSE.
+C     --------
+C     Computes the reflectivity and transmissivity in case oF
+C     Continuum scattering
+c     F. Forget (1999)
+c
+c      BASED ON MORCRETTE EARTH MODEL
+C     (See radiation's part of the ecmwf research department
+C     documentation, and Fouquart and BonneL (1980)
+C     
+C     IMPLICIT ARGUMENTS :
+C     --------------------
+C     
+C     ==== INPUTS ===
+c
+c    KDLON :  number of horizontal grid points
+c    KFLEV :  number of vertical layers
+c    KNU   :   Solar band # (1 or 2)
+c   aerosol               aerosol extinction optical depth
+c                         at reference wavelength "longrefvis" set
+c                         in dimradmars.h , in each layer, for one of
+c                         the "naerkind" kind of aerosol optical properties.
+c    albedo   hemispheric surface albedo
+c                         albedo (i,1) : mean albedo for solar band#1
+c                                        (see below)
+c                         albedo (i,2) : mean albedo for solar band#2
+c                                        (see below)
+c    PDSIG      layer thickness in sigma coordinates
+c    PPSOL       Surface pressure (Pa)
+c    PRMU:  cos of solar zenith angle (=1 when sun at zenith)
+c           (CORRECTED for high zenith angle (atmosphere), unlike mu0)
+c    PSEC   =1./PRMU
+
+C     ==== OUTPUTS ===
+c
+c    PFD : downward flux in spectral band #INU in a given mesh
+c         (normalized to the total incident flux at the top of the atmosphere)
+c    PFU : upward flux in specatral band #INU in a given mesh
+c         (normalized to the total incident flux at the top of the atmosphere)
+C
+C     
+C     METHOD.
+C     -------
+C     
+C     Computes continuum fluxes corresponding to aerosoL
+C     Or/and rayleigh scattering (no molecular gas absorption)
+C     
+C-----------------------------------------------------------------------
+C     
+C     
+C-----------------------------------------------------------------------
+C     
+     
+C     ARGUMENTS
+C     ---------
+      INTEGER KDLON, KFLEV, KNU
+      REAL aerosol(NDLO2,KFLEV,naerkind), albedo(NDLO2,2), 
+     S     PDSIG(NDLO2,KFLEV),PSEC(NDLO2)
+      REAL PPSOL(NDLO2)
+      REAL PFD(NDLO2,KFLEV+1),PFU(NDLO2,KFLEV+1)
+      REAL PRMU(NDLO2)
+
+C     LOCAL ARRAYS
+C     ------------
+ 
+      INTEGER jk,ja,jl,jae, jkl,jklp1,jkm1,jaj
+      REAL ZTRAY, ZRATIO,ZGAR, ZFF
+      real zfacoa,zcorae
+      real ZMUE, zgap,zbmu0, zww,zto,zden,zmu1,zbmu1,zden1,zre11
+
+      REAL ZC1I(NDLON,NFLEV+1), ZGG(NDLON), ZREF(NDLON)
+     S ,  ZRE1(NDLON), ZRE2(NDLON)
+     S ,  ZRMUZ(NDLON), ZRNEB(NDLON), ZR21(NDLON)
+     S ,  ZR23(NDLON),  ZSS1(NDLON), ZTO1(NDLON), ZTR(NDLON,2,NFLEV+1)
+     S ,  ZTR1(NDLON), ZTR2(NDLON), ZW(NDLON)
+
+      REAL ZRAY1(NDLO2,NFLEV+1), ZRAY2(NDLO2,NFLEV+1)
+     s   ,  ZREFZ(NDLO2,2,NFLEV+1)
+     S   ,  ZRMUE(NDLO2,NFLEV+1)
+     S   ,  ZCGAZ(NDLO2,NFLEV),ZPIZAZ(NDLO2,NFLEV),ZTAUAZ(NDLO2,NFLEV)
+
+      REAL  ZRAYL(NDLON)
+     S     ,   ZRJ(NDLON,6,NFLEV+1)
+     S     ,  ZRK(NDLON,6,NFLEV+1)
+     S     ,  ZTRA1(NDLON,NFLEV+1), ZTRA2(NDLON,NFLEV+1)
+
+
+      real ray,coefsizew
+
+c     Function
+c     --------
+      real CVMGT
+
+C    --------------------------------
+C     OPTICAL PARAMETERS FOR AEROSOLS 
+C     -------------------------------
+C     
+      DO  JK = 1 , nlaylte+1
+         DO  JA = 1 , 6
+            DO JL = 1 , KDLON
+               ZRJ(JL,JA,JK) = 0.
+               ZRK(JL,JA,JK) = 0.
+            END DO
+         END DO
+      END DO
+
+c Computing TOTAL single scattering parameters by adding
+c  properties of all the NAERKIND kind of aerosols
+
+      DO JK = 1 , nlaylte
+         DO  JL = 1 , KDLON
+            ZCGAZ(JL,JK) = 0.
+            ZPIZAZ(JL,JK) =  0.
+            ZTAUAZ(JL,JK) = 0.
+         END DO
+         DO 106 JAE=1,naerkind
+            DO 105 JL = 1 , KDLON
+c              Mean Extinction optical depth in the spectral band
+c              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+               ZTAUAZ(JL,JK)=ZTAUAZ(JL,JK)
+     S              +aerosol(JL,JK,JAE)*QVISsQREF(KNU,JAE)
+c              Single scattering albedo
+c              ~~~~~~~~~~~~~~~~~~~~~~~~ 
+c TEST : to account for the varying w with varying crystal size
+               if (activice.and.JAE.eq.naerkind.and.KNU.eq.2) then
+                 ray=min( max(rice(JL,JK)*1.e+6, 1.),10.) 
+	         coefsizew=(0.0001417*ray**2.-0.00328*ray+0.99667)
+     &             /omegavis(KNU,JAE)
+	       else
+		 coefsizew=1.
+               endif
+               ZPIZAZ(JL,JK)=ZPIZAZ(JL,JK)+aerosol(JL,JK,JAE)
+     S           * QVISsQREF(KNU,JAE)*omegavis(KNU,JAE)*coefsizew
+c              Assymetry factor 
+c              ~~~~~~~~~~~~~~~~
+               ZCGAZ(JL,JK) =  ZCGAZ(JL,JK) +aerosol(JL,JK,JAE)
+     S            * QVISsQREF(KNU,JAE)*omegavis(KNU,JAE)*gvis(KNU,JAE)
+ 105        CONTINUE
+ 106     CONTINUE
+      END DO
+C     
+      DO JK = 1 , nlaylte
+         DO JL = 1 , KDLON
+            ZCGAZ(JL,JK) = CVMGT( 0., ZCGAZ(JL,JK) / ZPIZAZ(JL,JK),
+     S            (ZPIZAZ(JL,JK).EQ.0) )
+            ZPIZAZ(JL,JK) = CVMGT( 1., ZPIZAZ(JL,JK) / ZTAUAZ(JL,JK),
+     S           (ZTAUAZ(JL,JK).EQ.0) )
+         END DO
+      END DO
+
+C     --------------------------------
+C     INCLUDING RAYLEIGH SCATERRING 
+C     -------------------------------
+      if (rayleigh) then 
+
+        call swrayleigh(kdlon,knu,ppsol,prmu,ZRAYL)
+
+c       Modifying mean aerosol parameters to account rayleigh scat by gas:
+
+        DO JK = 1 , nlaylte
+           DO JL = 1 , KDLON
+c             Rayleigh opacity in each layer :
+              ZTRAY = ZRAYL(JL) * PDSIG(JL,JK)
+c             ratio Tau(rayleigh) / Tau (total)
+              ZRATIO = ZTRAY / (ZTRAY + ZTAUAZ(JL,JK))
+              ZGAR = ZCGAZ(JL,JK)
+              ZFF = ZGAR * ZGAR
+                ZTAUAZ(JL,JK)=ZTRAY+ZTAUAZ(JL,JK)*(1.-ZPIZAZ(JL,JK)*ZFF)
+              ZCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+              ZPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*ZPIZAZ(JL,JK)*(1.-ZFF)
+     S           / (1. -ZPIZAZ(JL,JK) * ZFF)
+           END DO
+        END DO
+      end if
+
+     
+C     ----------------------------------------------
+C     TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C     ----------------------------------------------
+C     
+ 200  CONTINUE
+      
+      DO JL = 1 , KDLON
+         ZR23(JL) = 0.
+         ZC1I(JL,nlaylte+1) = 0.
+      END DO
+      
+      DO JK = 1 , nlaylte
+         JKL = nlaylte+1 - JK
+         JKLP1 = JKL + 1
+         DO JL = 1 , KDLON
+            ZFACOA = 1.-ZPIZAZ(JL,JKL)*ZCGAZ(JL,JKL)*ZCGAZ(JL,JKL)
+            ZCORAE = ZFACOA * ZTAUAZ(JL,JKL) * PSEC(JL)
+            ZR21(JL) = EXP(-ZCORAE   )
+            ZSS1(JL) =  1.0-ZR21(JL)
+            ZC1I(JL,JKL) = 1.0-(1.0-ZSS1(JL))*(1.0-ZC1I(JL,JKLP1))
+         END DO
+      END DO
+
+C     -----------------------------------------------
+C     REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C     -----------------------------------------------
+C     
+      DO JL = 1 , KDLON
+         ZRAY1(JL,nlaylte+1) = 0.
+         ZRAY2(JL,nlaylte+1) = 0.
+         ZREFZ(JL,2,1) = albedo(JL,KNU)
+         ZREFZ(JL,1,1) = albedo(JL,KNU)
+         ZTRA1(JL,nlaylte+1) = 1.
+         ZTRA2(JL,nlaylte+1) = 1.
+      END DO
+
+      DO JK = 2 , nlaylte+1
+         JKM1 = JK-1
+         DO 342 JL = 1 , KDLON
+            ZRNEB(JL)= 1.e-5   ! used to be "cloudiness" (PCLDSW in Morcrette)
+
+            ZRE1(JL)=0.
+            ZTR1(JL)=0.
+            ZRE2(JL)=0.
+            ZTR2(JL)=0.
+      
+C           EQUIVALENT ZENITH ANGLE
+c           ~~~~~~~~~~~~~~~~~~~~~~~
+            ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S           + ZC1I(JL,JK) * 1.66
+            ZRMUE(JL,JK) = 1./ZMUE
+
+C     ------------------------------------------------------------------
+C          REFLECT./TRANSMISSIVITY DUE TO AEROSOLS (and rayleigh ?)
+C     ------------------------------------------------------------------
+
+            ZGAP = ZCGAZ(JL,JKM1)
+            ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+            ZWW =ZPIZAZ(JL,JKM1)
+            ZTO = ZTAUAZ(JL,JKM1)
+            ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S           + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+            ZRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+            ZTRA1(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
+            ZRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+            ZTRA2(JL,JKM1) = 1. / ZDEN1
+
+            ZGG(JL) =  ZCGAZ(JL,JKM1)
+            ZW(JL) =ZPIZAZ(JL,JKM1)
+            ZREF(JL) = ZREFZ(JL,1,JKM1)
+            ZRMUZ(JL) = ZRMUE(JL,JK)
+            ZTO1(JL) =  ZTAUAZ(JL,JKM1)/ZPIZAZ(JL,JKM1)
+
+ 342     CONTINUE
+
+C     
+         CALL DEDD ( KDLON
+     S        , ZGG,ZREF,ZRMUZ,ZTO1,ZW
+     S        , ZRE1,ZRE2,ZTR1,ZTR2     )
+C     
+         DO JL = 1 , KDLON
+C     
+            ZREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S           + ZREFZ(JL,1,JKM1) * ZTRA1(JL,JKM1)
+     S           * ZTRA2(JL,JKM1)
+     S           / (1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))
+     S           + ZRNEB(JL) * ZRE2(JL)
+C     
+            ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (ZTRA1(JL,JKM1)
+     S           / (1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))
+     S           * (1.-ZRNEB(JL))
+C     
+            ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S           + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S           * ZTRA2(JL,JKM1) )
+     S           + ZRNEB(JL) * ZRE1(JL)
+C     
+            ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S           + ZTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C     
+         END DO
+      END DO 
+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
+            ZRJ(JL,JAJ,nlaylte+1) = 1.
+            ZRK(JL,JAJ,nlaylte+1) = ZREFZ(JL, 1,nlaylte+1)
+ 351     CONTINUE
+C     
+         DO 353 JK = 1 , nlaylte
+            JKL = nlaylte+1 - JK
+            JKLP1 = JKL + 1
+            DO 352 JL = 1 , KDLON
+               ZRE11= ZRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+               ZRJ(JL,JAJ,JKL) = ZRE11
+               ZRK(JL,JAJ,JKL) = ZRE11 * ZREFZ(JL,  1,JKL)
+ 352        CONTINUE
+ 353     CONTINUE
+ 354     CONTINUE
+C     
+      ELSE
+C     
+         DO 358 JAJ = 1 , 2
+            DO 355 JL = 1 , KDLON
+               ZRJ(JL,JAJ,nlaylte+1) = 1.
+               ZRK(JL,JAJ,nlaylte+1) = ZREFZ(JL,JAJ,nlaylte+1)
+ 355        CONTINUE
+C     
+            DO 357 JK = 1 , nlaylte
+               JKL = nlaylte+1 - JK
+               JKLP1 = JKL + 1
+               DO 356 JL = 1 , KDLON
+                  ZRE11= ZRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+                  ZRJ(JL,JAJ,JKL) = ZRE11
+                  ZRK(JL,JAJ,JKL) = ZRE11 * ZREFZ(JL,JAJ,JKL)
+ 356           CONTINUE
+ 357        CONTINUE
+ 358     CONTINUE
+      END IF
+
+C     
+C     
+C     
+C     ------------------------------------------------------------------
+C     ---------------
+C     DOWNWARD FLUXES
+C     ---------------
+C    
+      JAJ = 2
+
+      do JK = 1 , nlaylte+1
+        JKL = nlaylte+1 - JK + 1
+        DO  JL = 1 , KDLON
+            PFD(JL,JKL) =   ZRJ(JL,JAJ,JKL) * sunfr(KNU)
+        end do
+      end do
+C    
+C  -------------
+C  UPWARD FLUXES
+C  -------------
+      DO JK = 1 , nlaylte+1
+         DO  JL = 1 , KDLON
+c           ZRK = upward flux / incident top flux
+            PFU(JL,JK) =    ZRK(JL,JAJ,JK) * sunfr(KNU)
+         END DO
+      END DO
+
+C     
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swrayleigh.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swrayleigh.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/swrayleigh.F	(revision 57)
@@ -0,0 +1,86 @@
+      SUBROUTINE swrayleigh(kdlon,knu,ppsol,prmu,prayl)
+                                                   
+       IMPLICIT NONE
+c=======================================================================
+c   subject:
+c   --------
+c   Computing total rayleigh scat atmospheric optical depth  
+c
+c   author: F.Forget 
+c   ------
+c
+c   input:
+c   ----- 
+c   kdlon             Number of gridpoint of horizontal grid
+c    knu   :   Solar band # (1 or 2)
+c   ppsol             surface pressure (Pa) 
+c   prmu         cos of solar zenith angle (=1 when sun at zenith)
+c           (CORRECTED for high zenith angle (atmosphere), unlike mu0)
+c
+c   output:
+c   -------
+c   prayl       column optical depth in each model column
+c
+c=======================================================================
+#include "comcstfi.h"
+
+c-----------------------------------------------------------------------
+c
+c    Declarations :
+c    --------------
+c
+c    Input/Output
+c    ------------
+      INTEGER kdlon, knu
+
+      real ppsol(kdlon),prmu(kdlon),prayl(kdlon)
+c
+c    Local variables :
+c    -----------------
+      integer JL, K
+c
+c   local saved variables
+c   ---------------------
+c     rayleigh scattering coefficients (from Morcrete et al.EARTH model !)
+      real cray(2,6)
+
+      DATA (CRAY(1,K),K=1,6) /
+     S     .428937E-01, .890743E+00,-.288555E+01,
+     S     .522744E+01,-.469173E+01, .161645E+01/
+
+      DATA (CRAY(2,K),K=1,6) /
+     S     .697200E-02, .173297E-01,-.850903E-01,
+     S     .248261E+00,-.302031E+00, .129662E+00/
+      save cray
+c----------------------------------------------------------------------
+
+      DO JL = 1 , KDLON
+
+c        Total Rayleigh Optical thickness on Earth at 101325 Pa level
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c        WARNING : the CRAY coefficients are only valid for
+c        Spectral interval used in Earth model !!!
+c        (i.e. 0.25-0.68 micron and 0.68-4.00 micron
+c         ---> should be modified for Mars model !!!
+
+         PRAYL(JL) = CRAY(KNU,1) + PRMU(JL) * (CRAY(KNU,2) + PRMU(JL)
+     S        * (CRAY(KNU,3) + PRMU(JL) * (CRAY(KNU,4) + PRMU(JL)
+     S        * (CRAY(KNU,5) + PRMU(JL) *   CRAY(KNU,6)       ))))
+
+c        Total local Rayleigh Optical thickness on Mars
+c        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c           - PRAYL above is the total Rayleigh Optical thickness
+c             at  101325Pa for Earth atmosphere
+c           -> Total Rayleigh Optical thickness on Mars
+c              = PRAYL*(Psurf/101325)*9.81/g *2.5
+c              (Extinction coeff of CO2 = 2.5 * N2)
+
+c     (Comment the following line to get back bugged version before 01/2000)
+c        PRAYL(JL) = PRAYL(JL) * PPSOL(JL) * 2.42e-4/g
+
+      END DO
+
+
+      return
+      end 
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tabfi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tabfi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tabfi.F	(revision 57)
@@ -0,0 +1,514 @@
+c=======================================================================
+      SUBROUTINE tabfi(nid,Lmodif,tab0,day_ini,lmax,p_rad,
+     .                 p_omeg,p_g,p_mugaz,p_daysec,time)
+c=======================================================================
+c
+c   C. Hourdin 15/11/96
+c
+c   Object:        Lecture du tab_cntrl physique dans un fichier 
+c   ------            et initialisation des constantes physiques
+c
+c   Arguments:
+c   ----------
+c
+c     Inputs:
+c     ------
+c
+c      - nid:    unitne logique du fichier ou on va lire le tab_cntrl    
+c                      (ouvert dans le programme appellant) 
+c
+c                 si nid=0:
+c                       pas de lecture du tab_cntrl mais
+c                       Valeurs par default des constantes physiques
+c        
+c      - tab0:    Offset de tab_cntrl a partir duquel sont ranges 
+c                  les parametres physiques (50 pour start_archive)
+c
+c      - Lmodif:  si on souhaite modifier les constantes  Lmodif = 1 = TRUE
+c
+c
+c     Outputs:
+c     --------
+c
+c      - day_ini: tab_cntrl(tab0+3) (Dans les cas ou l'on souhaite
+c                              comparer avec le day_ini dynamique)
+c
+c      - lmax:    tab_cntrl(tab0+2) (pour test avec nlayermx)
+c
+c      - p_rad
+c      - p_omeg   !
+c      - p_g      ! Constantes physiques ayant des 
+c      - p_mugaz  ! homonymes dynamiques
+c      - p_daysec !
+c
+c=======================================================================
+ 
+      implicit none
+ 
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "comgeomfi.h"
+#include "planete.h"
+#include "surfdat.h"
+#include "netcdf.inc"
+#include "dimradmars.h"
+#include "yomaer.h"
+
+c-----------------------------------------------------------------------
+c   Declarations
+c-----------------------------------------------------------------------
+
+c Arguments
+c ---------
+      INTEGER nid,nvarid,tab0
+      INTEGER*4 day_ini
+      INTEGER Lmodif
+      INTEGER lmax
+      REAL p_rad,p_omeg,p_g,p_mugaz,p_daysec,time
+
+c Variables
+c ---------
+      INTEGER length
+      parameter (length = 100)
+      REAL tab_cntrl(length) ! tableau des parametres du run
+      INTEGER  ierr
+      INTEGER size
+      CHARACTER modif*20
+
+c Fonctions DRS et autres
+c -----------------------
+      INTEGER setname, cluvdb, getdat
+
+      INTEGER lnblnk
+
+c-----------------------------------------------------------------------
+c  Initialisation des constantes physiques par defaut (cas nid = 0)
+c-----------------------------------------------------------------------
+      IF (nid.eq.0) then
+ 
+c Pression de reference sur la planete
+c-------------------------------------
+c     pressrf = 670.            ! Pression de reference (Pa) ~650
+
+c Info sur la Planete Mars pour la dynamique et la physique
+c----------------------------------------------------------
+      rad=3397200.          ! rayon de mars (m)  ~3397200 m
+      daysec=88775.         ! duree du sol (s)  ~88775 s
+      omeg=4.*asin(1.)/(daysec)       ! vitesse de rotation (rad.s-1)
+      g=3.72                ! gravite (m.s-2) ~3.72
+      mugaz=43.49           ! Masse molaire de l''atm (g.mol-1) ~43.49
+      rcp=.256793         ! = r/cp  ~0.256793
+
+c Info sur la Planete Mars pour la physique uniquement
+c-----------------------------------------------------
+      year_day = 669.       !modif FH  duree de l''annee (sols) ~668.6
+      periheli = 206.66         ! dist.min. soleil-mars (Mkm) ~206.66
+      aphelie = 249.22          ! dist.max. soleil-mars (Mkm) ~249.22
+      peri_day =  485.    ! date du perihelie (sols depuis printemps)
+      obliquit = 25.19         ! Obliquite de la planete (deg) ~25.19
+
+c Couche limite et Turbulence
+c----------------------------
+      z0 =  1.e-2               ! surface roughness (m) ~0.01
+      emin_turb = 1.e-6         ! energie minimale ~1.e-8
+      lmixmin = 30              ! longueur de melange ~100
+
+c propriete optiques des calottes et emissivite du sol
+c-----------------------------------------------------
+      emissiv=.95               ! Emissivite du sol martien ~.95
+      emisice(1)=0.95           ! Emissivite calotte nord
+      emisice(2)=0.95           ! Emissivite calotte sud
+      albedice(1)=0.65          ! Albedo calotte nord
+      albedice(2)=0.65          ! Albedo calotte sud
+      iceradius(1) = 100.e-6    ! mean scat radius of CO2 snow (north)
+      iceradius(2) = 100.e-6    ! mean scat radius of CO2 snow (south)
+      dtemisice(1) = 0.4   ! time scale for snow metamorphism (north)
+      dtemisice(2) = 0.4   ! time scale for snow metamorphism (south)
+
+c Proprietes des poussiere aerosol
+c---------------------------------
+      tauvis= 0.2          ! profondeur optique visible moyenne
+
+c  Ancien code radiatif (non utilise avec le code d'apres 03/96)
+c---------------------------------------------------------------
+c     tauir= 0.  ! .2  ratio (mean IR opt.depth)/Visible
+c     scatalb=0. ! .86 scaterring albedo visible (~.86)
+c     asfact=0.  ! .79 assymetrie factor visible   (~.79)
+c     day0 = 0   ! = 0 en general !!!
+ 
+c-----------------------------------------------------------------------
+c  Initialisation des constantes physiques par lecture du tableau 
+c		des parametres du run (tab_cntrl) 	(cas nid != 0)
+c-----------------------------------------------------------------------
+      ELSE
+
+c Lecture du tableau
+c
+      ierr = NF_INQ_VARID (nid, "controle", nvarid)
+      IF (ierr .NE. NF_NOERR) THEN
+         PRINT*, "Tabfi: 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*, "Tabfi: Lecture echoue pour <controle>"
+         CALL abort
+      ENDIF
+
+       print*,'tab_cntrl',tab_cntrl
+c
+c  Initialisation des constantes physiques
+c infor sur la grille physique
+      if(ngridmx.ne.tab_cntrl(tab0+1)) then
+         print*,'WARNING !!! tab_cntrl(tab0+1).ne.ngridmx'
+         print*,tab_cntrl(tab0+1),ngridmx
+      endif
+      lmax = nint(tab_cntrl(tab0+2))
+      day_ini = tab_cntrl(tab0+3)
+      time = tab_cntrl(tab0+4)
+      write (*,*) 'IN tabfi day_ini=',day_ini
+c Info sur la Planete Mars pour la dynamique et la physique
+      rad = tab_cntrl(tab0+5)
+      omeg = tab_cntrl(tab0+6)
+      g = tab_cntrl(tab0+7)
+      mugaz = tab_cntrl(tab0+8)
+      rcp = tab_cntrl(tab0+9)
+      daysec = tab_cntrl(tab0+10)
+      dtphys = tab_cntrl(tab0+11)
+c Info sur la Planete Mars pour la physique uniquement
+      year_day = tab_cntrl(tab0+14)
+      periheli = tab_cntrl(tab0+15)
+      aphelie = tab_cntrl(tab0+16)
+      peri_day = tab_cntrl(tab0+17)
+      obliquit = tab_cntrl(tab0+18)
+c couche limite et turbeulence
+      z0 = tab_cntrl(tab0+19)
+      lmixmin = tab_cntrl(tab0+20)
+      emin_turb = tab_cntrl(tab0+21)
+c proprietes optiques des calottes et emissivite du sol
+      albedice(1)= tab_cntrl(tab0+22)
+      albedice(2)= tab_cntrl(tab0+23)
+      emisice(1) = tab_cntrl(tab0+24)
+      emisice(2) = tab_cntrl(tab0+25)
+      emissiv    = tab_cntrl(tab0+26)
+      tauvis     = tab_cntrl(tab0+27)  ! dust opt. depth vis.
+      iceradius(1)= tab_cntrl(tab0+31) ! mean scat radius of CO2 snow (north)
+      iceradius(2)= tab_cntrl(tab0+32) ! mean scat radius of CO2 snow (south)
+      dtemisice(1)= tab_cntrl(tab0+33) !time scale for snow metamorphism (north)
+      dtemisice(2)= tab_cntrl(tab0+34) !time scale for snow metamorphism (south)
+c-----------------------------------------------------------------------
+c	Sauvegarde des constantes pour passages en arguments
+c-----------------------------------------------------------------------
+      p_omeg = omeg
+      p_g = g
+      p_mugaz = mugaz
+      p_daysec = daysec
+      p_rad=rad
+
+      ENDIF    ! (du if nid = 0) 
+
+c-----------------------------------------------------------------------
+c	Impression des constantes physiques avant modif
+c-----------------------------------------------------------------------
+ 
+   6  FORMAT(a20,e15.6,e15.6)
+   5  FORMAT(a20,f12.2,f12.2)
+ 
+      write(*,*) '*****************************************************'
+      write(*,*) 'lecture du tab_cntrl a l appel de tabfi avant modif'
+      write(*,*) '*****************************************************'
+      write(*,5) '(1)      = ngridmx?',tab_cntrl(tab0+1),float(ngridmx)
+      write(*,5) '(2)            lmax',tab_cntrl(tab0+2),float(lmax)
+      write(*,5) '(3)         day_ini',tab_cntrl(tab0+3),float(day_ini)
+      write(*,5) '(5)             rad',tab_cntrl(tab0+5),rad
+      write(*,5) '(10)         daysec',tab_cntrl(tab0+10),daysec
+      write(*,6) '(6)            omeg',tab_cntrl(tab0+6),omeg
+      write(*,5) '(7)               g',tab_cntrl(tab0+7),g
+      write(*,5) '(8)           mugaz',tab_cntrl(tab0+8),mugaz
+      write(*,5) '(9)             rcp',tab_cntrl(tab0+9),rcp
+      write(*,6) '(11)        dtphys?',tab_cntrl(tab0+11),dtphys
+
+      write(*,5) '(14)       year_day',tab_cntrl(tab0+14),year_day
+      write(*,5) '(15)       periheli',tab_cntrl(tab0+15),periheli
+      write(*,5) '(16)        aphelie',tab_cntrl(tab0+16),aphelie
+      write(*,5) '(17)       peri_day',tab_cntrl(tab0+17),peri_day
+      write(*,5) '(18)       obliquit',tab_cntrl(tab0+18),obliquit
+
+      write(*,6) '(19)             z0',tab_cntrl(tab0+19),z0
+      write(*,6) '(21)      emin_turb',tab_cntrl(tab0+21),emin_turb
+      write(*,5) '(20)        lmixmin',tab_cntrl(tab0+20),lmixmin
+
+      write(*,5) '(26)        emissiv',tab_cntrl(tab0+26),emissiv
+      write(*,5) '(24)     emisice(1)',tab_cntrl(tab0+24),emisice(1)
+      write(*,5) '(25)     emisice(2)',tab_cntrl(tab0+25),emisice(2)
+      write(*,5) '(22)    albedice(1)',tab_cntrl(tab0+22),albedice(1)
+      write(*,5) '(23)    albedice(2)',tab_cntrl(tab0+23),albedice(2)
+      write(*,6) '(31)   iceradius(1)',tab_cntrl(tab0+31),iceradius(1)
+      write(*,6) '(32)   iceradius(2)',tab_cntrl(tab0+32),iceradius(2)
+      write(*,5) '(33)   dtemisice(1)',tab_cntrl(tab0+33),dtemisice(1)
+      write(*,5) '(34)   dtemisice(2)',tab_cntrl(tab0+34),dtemisice(2)
+
+      write(*,5) '(27)         tauvis',tab_cntrl(tab0+27),tauvis
+
+      write(*,*)
+      write(*,*) 'Lmodif dans tabfi!!!!!!!',Lmodif
+
+c-----------------------------------------------------------------------
+c	 Modifications...
+c-----------------------------------------------------------------------
+
+      IF(Lmodif.eq.1) then
+
+      write(*,*)
+      write(*,*) 'Modifications des valeurs du tab_cntrl:'
+      write(*,*) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
+      write(*,*) '(valeurs actuelles indiquees ci-dessus)'
+      write(*,*)
+      write(*,*) '(3)          day_ini : Jour initial (=0 a Ls=0)'
+      write(*,*) '(19)              z0 :  surface roughness (m)'
+      write(*,*) '(21)       emin_turb :  energie minimale'
+      write(*,*) '(20)         lmixmin : longueur de melange'
+      write(*,*) '(26)         emissiv : Emissivite du sol martien'
+      write(*,*) '(24 et 25)   emisice : Emissivite des calottes '
+      write(*,*) '(22 et 23)  albedice : Albedo des calotte'
+      write(*,*) '(31 et 32) iceradius : mean scat radius of CO2 snow'
+      write(*,*) '(33 et 34) dtemisice : time scale for snow',
+     . ' metamorphism'
+      write(*,*) '(27)          tauvis : profondeur optique visible',
+     . ' moyenne'
+      write(*,*) '(18)        obliquit : planet obliquity (deg)'
+      write(*,*) '(17)      peri_day : perihelion date (sol since Ls=0)'
+      write(*,*) '(15)      periheli : min. sun-mars dist (Mkm)'
+      write(*,*) '(16)      aphelie  : max. sun-mars dist (Mkm)'
+      write(*,*)
+ 
+ 
+      do while(modif(1:1).ne.'hello')
+        write(*,*)
+        write(*,*)
+        write(*,*) 'modification a faire ?'
+        write(*,*) '   (entrer le mot cle ou return pour finir)'
+        write(*,*)
+        read(*,fmt='(a20)') modif
+        if (modif(1:1) .eq. ' ') goto 999
+ 
+        write(*,*)
+        write(*,*) modif(1:lnblnk(modif)) , ' : '
+
+        if (modif(1:lnblnk(modif)) .eq. 'day_ini') then
+          write(*,*) 'valeur actuelle:',day_ini
+          write(*,*) 'entrer la nouvelle valeur:'
+ 101      read(*,*,iostat=ierr) day_ini
+          if(ierr.ne.0) goto 101
+          write(*,*) ' '
+          write(*,*) 'day_ini (nouvelle valeur):',day_ini
+
+        else if (modif(1:lnblnk(modif)) .eq. 'z0') then
+          write(*,*) 'valeur actuelle:',z0
+          write(*,*) 'entrer la nouvelle valeur:'
+ 102      read(*,*,iostat=ierr) z0
+          if(ierr.ne.0) goto 102
+          write(*,*) ' '
+          write(*,*) ' z0 (nouvelle valeur):',z0
+
+        else if (modif(1:lnblnk(modif)) .eq. 'emin_turb') then
+          write(*,*) 'valeur actuelle:',emin_turb
+          write(*,*) 'entrer la nouvelle valeur:'
+ 103      read(*,*,iostat=ierr) emin_turb
+          if(ierr.ne.0) goto 103
+          write(*,*) ' '
+          write(*,*) ' emin_turb (nouvelle valeur):',emin_turb
+
+        else if (modif(1:lnblnk(modif)) .eq. 'lmixmin') then
+          write(*,*) 'valeur actuelle:',lmixmin
+          write(*,*) 'entrer la nouvelle valeur:'
+ 104      read(*,*,iostat=ierr) lmixmin
+          if(ierr.ne.0) goto 104
+          write(*,*) ' '
+          write(*,*) ' lmixmin (nouvelle valeur):',lmixmin
+
+        else if (modif(1:lnblnk(modif)) .eq. 'emissiv') then
+          write(*,*) 'valeur actuelle:',emissiv
+          write(*,*) 'entrer la nouvelle valeur:'
+ 105      read(*,*,iostat=ierr) emissiv
+          if(ierr.ne.0) goto 105
+          write(*,*) ' '
+          write(*,*) ' emissiv (nouvelle valeur):',emissiv
+
+        else if (modif(1:lnblnk(modif)) .eq. 'emisice') then
+          write(*,*) 'valeur actuelle emisice(1) Nord:',emisice(1)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 106      read(*,*,iostat=ierr) emisice(1)
+          if(ierr.ne.0) goto 106
+          write(*,*) 
+          write(*,*) ' emisice(1) (nouvelle valeur):',emisice(1)
+          write(*,*)
+
+          write(*,*) 'valeur actuelle emisice(2) Sud:',emisice(2)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 107      read(*,*,iostat=ierr) emisice(2)
+          if(ierr.ne.0) goto 107
+          write(*,*) 
+          write(*,*) ' emisice(2) (nouvelle valeur):',emisice(2)
+
+        else if (modif(1:lnblnk(modif)) .eq. 'albedice') then
+          write(*,*) 'valeur actuelle albedice(1) Nord:',albedice(1)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 108      read(*,*,iostat=ierr) albedice(1)
+          if(ierr.ne.0) goto 108
+          write(*,*) 
+          write(*,*) ' albedice(1) (nouvelle valeur):',albedice(1)
+          write(*,*)
+
+          write(*,*) 'valeur actuelle albedice(2) Sud:',albedice(2)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 109      read(*,*,iostat=ierr) albedice(2)
+          if(ierr.ne.0) goto 109
+          write(*,*) 
+          write(*,*) ' albedice(2) (nouvelle valeur):',albedice(2)
+
+        else if (modif(1:lnblnk(modif)) .eq. 'iceradius') then
+          write(*,*) 'valeur actuelle iceradius(1) Nord:',iceradius(1)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 110      read(*,*,iostat=ierr) iceradius(1)
+          if(ierr.ne.0) goto 110
+          write(*,*) 
+          write(*,*) ' iceradius(1) (nouvelle valeur):',iceradius(1)
+          write(*,*)
+
+          write(*,*) 'valeur actuelle iceradius(2) Sud:',iceradius(2)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 111      read(*,*,iostat=ierr) iceradius(2)
+          if(ierr.ne.0) goto 111
+          write(*,*) 
+          write(*,*) ' iceradius(2) (nouvelle valeur):',iceradius(2)
+
+        else if (modif(1:lnblnk(modif)) .eq. 'dtemisice') then
+          write(*,*) 'valeur actuelle dtemisice(1) Nord:',dtemisice(1)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 112      read(*,*,iostat=ierr) dtemisice(1)
+          if(ierr.ne.0) goto 112
+          write(*,*) 
+          write(*,*) ' dtemisice(1) (nouvelle valeur):',dtemisice(1)
+          write(*,*)
+
+          write(*,*) 'valeur actuelle dtemisice(2) Sud:',dtemisice(2)
+          write(*,*) 'entrer la nouvelle valeur:'
+ 113      read(*,*,iostat=ierr) dtemisice(2)
+          if(ierr.ne.0) goto 113
+          write(*,*) 
+          write(*,*) ' dtemisice(2) (nouvelle valeur):',dtemisice(2)
+
+        else if (modif(1:lnblnk(modif)) .eq. 'tauvis') then
+          write(*,*) 'valeur actuelle:',tauvis
+          write(*,*) 'entrer la nouvelle valeur:'
+ 114      read(*,*,iostat=ierr) tauvis
+          if(ierr.ne.0) goto 114
+          write(*,*) 
+          write(*,*) ' tauvis (nouvelle valeur):',tauvis
+        else if (modif(1:lnblnk(modif)) .eq. 'obliquit') then
+          write(*,*) 'valeur actuelle:',obliquit
+          write(*,*) 'obliquit should be 25.19 on current Mars'
+          write(*,*) 'entrer la nouvelle valeur:'
+ 115      read(*,*,iostat=ierr) obliquit
+          if(ierr.ne.0) goto 115
+          write(*,*) 
+          write(*,*) ' obliquit (nouvelle valeur):',obliquit
+
+        else if (modif(1:lnblnk(modif)) .eq. 'peri_day') then
+          write(*,*) 'valeur actuelle:',peri_day
+          write(*,*) 'peri_day should be 485 on current Mars'
+          write(*,*) 'entrer la nouvelle valeur:'
+ 116      read(*,*,iostat=ierr) peri_day
+          if(ierr.ne.0) goto 116
+          write(*,*) 
+          write(*,*) ' peri_day (nouvelle valeur):',peri_day
+
+        else if (modif(1:lnblnk(modif)) .eq. 'periheli') then
+          write(*,*) 'valeur actuelle:',periheli
+          write(*,*) 'periheli should be 206.66 on current Mars'
+          write(*,*) 'entrer la nouvelle valeur:'
+ 117      read(*,*,iostat=ierr) periheli
+          if(ierr.ne.0) goto 117
+          write(*,*) 
+          write(*,*) ' periheli (nouvelle valeur):',periheli
+ 
+        else if (modif(1:lnblnk(modif)) .eq. 'aphelie') then
+          write(*,*) 'valeur actuelle:',aphelie
+          write(*,*) 'aphelie should be 249.22 on current Mars'
+          write(*,*) 'entrer la nouvelle valeur:'
+ 118      read(*,*,iostat=ierr) aphelie
+          if(ierr.ne.0) goto 118
+          write(*,*) 
+          write(*,*) ' aphelie (nouvelle valeur):',aphelie
+ 
+        endif
+      enddo
+
+ 999  continue
+
+c-----------------------------------------------------------------------
+c	Impression des constantes physiques apres modif si modif
+c-----------------------------------------------------------------------
+ 
+      write(*,*) '*****************************************************'
+      write(*,*) 'lecture du tab_cntrl a l appel de tabfi apres modif'
+      write(*,*) '*****************************************************'
+      write(*,5) '(1)      = ngridmx?',tab_cntrl(tab0+1),float(ngridmx)
+      write(*,5) '(2)            lmax',tab_cntrl(tab0+2),float(lmax)
+      write(*,5) '(3)         day_ini',tab_cntrl(tab0+3),float(day_ini)
+      write(*,5) '(5)             rad',tab_cntrl(tab0+5),rad
+      write(*,5) '(10)         daysec',tab_cntrl(tab0+10),daysec
+      write(*,6) '(6)            omeg',tab_cntrl(tab0+6),omeg
+      write(*,5) '(7)               g',tab_cntrl(tab0+7),g
+      write(*,5) '(8)           mugaz',tab_cntrl(tab0+8),mugaz
+      write(*,5) '(9)             rcp',tab_cntrl(tab0+9),rcp
+      write(*,6) '(11)        dtphys?',tab_cntrl(tab0+11),dtphys
+ 
+      write(*,5) '(14)       year_day',tab_cntrl(tab0+14),year_day
+      write(*,5) '(15)       periheli',tab_cntrl(tab0+15),periheli
+      write(*,5) '(16)        aphelie',tab_cntrl(tab0+16),aphelie
+      write(*,5) '(17)       peri_day',tab_cntrl(tab0+17),peri_day
+      write(*,5) '(18)       obliquit',tab_cntrl(tab0+18),obliquit
+ 
+      write(*,6) '(19)             z0',tab_cntrl(tab0+19),z0
+      write(*,6) '(21)      emin_turb',tab_cntrl(tab0+21),emin_turb
+      write(*,5) '(20)        lmixmin',tab_cntrl(tab0+20),lmixmin
+ 
+      write(*,5) '(26)        emissiv',tab_cntrl(tab0+26),emissiv
+      write(*,5) '(24)     emisice(1)',tab_cntrl(tab0+24),emisice(1)
+      write(*,5) '(25)     emisice(2)',tab_cntrl(tab0+25),emisice(2)
+      write(*,5) '(22)    albedice(1)',tab_cntrl(tab0+22),albedice(1)
+      write(*,5) '(23)    albedice(2)',tab_cntrl(tab0+23),albedice(2)
+      write(*,6) '(31)   iceradius(1)',tab_cntrl(tab0+31),iceradius(1)
+      write(*,6) '(32)   iceradius(2)',tab_cntrl(tab0+32),iceradius(2)
+      write(*,5) '(33)   dtemisice(1)',tab_cntrl(tab0+33),dtemisice(1)
+      write(*,5) '(34)   dtemisice(2)',tab_cntrl(tab0+34),dtemisice(2)
+ 
+      write(*,5) '(27)         tauvis',tab_cntrl(tab0+27),tauvis
+
+      write(*,*)  
+      write(*,*) 
+
+      ENDIF 			!	(du if Lmodif = 1)
+
+c-----------------------------------------------------------------------
+c	Case when using a start file from before March 1996 (without iceradius...
+c-----------------------------------------------------------------------
+      if (iceradius(1).eq.0) then 
+         iceradius(1) = 100.e-6
+         iceradius(2) = 100.e-6
+         dtemisice(1) = 0.4
+         dtemisice(2) = 0.4
+         write (*,*) ' WARNING : old initialisation file'
+         write (*,*) 'iceradius set to',iceradius(1),iceradius(2)  
+         write (*,*) 'dtemisice set to',dtemisice(1),dtemisice(2)  
+       end if
+
+c-----------------------------------------------------------------------
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/testphys1d.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/testphys1d.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/testphys1d.F	(revision 57)
@@ -0,0 +1,508 @@
+
+      PROGRAM testphys1d
+      IMPLICIT NONE
+
+c=======================================================================
+c   subject:
+c   --------
+c   PROGRAM useful to run physical part of the martian GCM in a 1D column
+c       
+c Can be compiled with a command like (e.g. for 25 layers)
+c  "makegcm -p mars -d 25 testphys1d"
+c It requires the files "testphys1d.def" "callphys.def"
+c      and a file describing the sigma layers (e.g. "z2sig.def")
+c
+c   author: Frederic Hourdin, R.Fournier,F.Forget
+c   -------
+c   
+c   update: 12/06/2003 including chemistry (S. Lebonnois) 
+c                            and water ice (F. Montmessin)
+c 
+c=======================================================================
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "dimradmars.h"
+#include "comgeomfi.h"
+#include "surfdat.h"
+#include "comdiurn.h"
+#include "callkeys.h"
+#include "comcstfi.h"
+#include "planete.h"
+#include "comsaison.h"
+#include "yomaer.h"
+#include "aerdust.h"
+#include "control.h"
+#include "comvert.h"
+#include "netcdf.inc"
+#include "comg1d.h"
+#include "watercap.h"
+#include "fisice.h"
+#include "logic.h"
+
+c --------------------------------------------------------------
+c  Declarations
+c --------------------------------------------------------------
+c
+      INTEGER unit           ! unite de lecture de "testphys1d.def"
+      INTEGER unitstart      ! unite d'ecriture de "startfi"
+      INTEGER nlayer,nlevel,nsoil,ndt
+      INTEGER ilayer,ilevel,isoil,idt,iq
+      LOGICAl firstcall,lastcall
+c
+      INTEGER day0          ! date initial (sol ; =0 a Ls=0)
+      REAL day           ! date durant le run
+      REAL time             ! time (0<time<1 ; time=0.5 a midi)
+      REAL play(nlayermx)   ! Pressure at the middle of the layers (Pa)
+      REAL plev(nlayermx+1) ! intermediate pressure levels (pa)
+      REAL psurf,tsurf      
+      REAL u(nlayermx),v(nlayermx)  ! zonal, meridional wind
+      REAL gru,grv   ! prescribed "geostrophic" background wind
+      REAL temp(nlayermx)   ! temperature at the middle of the layers
+      REAL q(nlayermx,nqmx) ! tracer mixing ratio (e.g. kg/kg)
+      REAL qsurf(nqmx)      ! tracer surface budget (e.g. kg.m-2)
+      REAL tsoil(nsoilmx)   ! subsurface soik temperature (K)
+      REAL co2ice           ! co2ice layer (kg.m-2)
+      REAL emis             ! surface layer
+      REAL q2(nlayermx+1)   ! Turbulent Kinetic Energy
+      REAL zlay(nlayermx)   ! altitude estimee dans les couches (km)
+
+c    Physical and dynamical tandencies (e.g.  m.s-2, K/s, Pa/s)
+      REAL du(nlayermx),dv(nlayermx),dtemp(nlayermx)
+      REAL dudyn(nlayermx),dvdyn(nlayermx),dtempdyn(nlayermx)
+      REAL dpsurf    
+      REAL dq(nlayermx,nqmx)
+      REAL dqdyn(nlayermx,nqmx)
+
+c   Various intermediate variables
+      INTEGER thermo
+      REAL zls
+      REAL phi(nlayermx),h(nlayermx),s(nlayermx)
+      REAL pks, ptif, w(nlayermx)
+      REAL qtotinit, mqtot(nqmx),qtot
+      INTEGER ierr, aslun
+      REAL tmp1(0:nlayermx),tmp2(0:nlayermx)
+      Logical  tracerdyn
+
+      character*2 str2
+
+c=======================================================================
+
+c=======================================================================
+c INITIALISATION
+c=======================================================================
+
+c ------------------------------------------------------
+c  Constantes prescrites ICI
+c ------------------------------------------------------
+
+      pi=2.E+0*asin(1.E+0)
+
+c     Constante de la Planete Mars
+c     ----------------------------
+      rad=3397200.               ! rayon de mars (m)  ~3397200 m
+      daysec=88775.              ! duree du sol (s)  ~88775 s
+      omeg=4.*asin(1.)/(daysec)  ! vitesse de rotation (rad.s-1)
+      g=3.72                     ! gravite (m.s-2) ~3.72  
+      mugaz=43.49                ! Masse molaire de l'atm (g.mol-1) ~43.49
+      rcp=.256793                ! = r/cp  ~0.256793
+      r= 8.314511E+0 *1000.E+0/mugaz
+      cpp= r/rcp
+      year_day = 669           ! duree de l'annee (sols) ~668.6
+      periheli = 206.66          ! dist.min. soleil-mars (Mkm) ~206.66
+      aphelie = 249.22           ! dist.max. soleil-mars (Mkm) ~249.22
+      peri_day =  485.           ! date du perihelie (sols depuis printemps)
+      obliquit = 25.2           ! Obliquite de la planete (deg) ~25.2         
+ 
+c     Parametres Couche limite et Turbulence 
+c     --------------------------------------
+      z0 =  1.e-2                ! surface roughness (m) ~0.01 
+      emin_turb = 1.e-6          ! energie minimale ~1.e-8
+      lmixmin = 30               ! longueur de melange ~100
+ 
+c     propriete optiques des calottes et emissivite du sol
+c     ----------------------------------------------------
+      emissiv= 0.95              ! Emissivite du sol martien ~.95
+      emisice(1)=0.95            ! Emissivite calotte nord
+      emisice(2)=0.95            ! Emissivite calotte sud  
+      albedice(1)=0.5           ! Albedo calotte nord
+      albedice(2)=0.5            ! Albedo calotte sud
+      iceradius(1) = 100.e-6     ! mean scat radius of CO2 snow (north)
+      iceradius(2) = 100.e-6     ! mean scat radius of CO2 snow (south)
+      dtemisice(1) = 2.          ! time scale for snow metamorphism (north)
+      dtemisice(2) = 2.          ! time scale for snow metamorphism (south
+      hybrid=.false.
+
+c ------------------------------------------------------
+c  Lecture des parametres dans "testphys1d.def" 
+c ------------------------------------------------------
+
+c   Opening parameters file "testphys1d.def"
+c   ---------------------------------------
+      unit =97
+      OPEN(unit,file='testphys1d.def',status='old',form='formatted'
+     .     ,iostat=ierr)
+
+      IF(ierr.ne.0) THEN
+        write(*,*) 'Problem to open "testphys1d.def'
+        write(*,*) 'Is it there ?'
+        stop
+      END IF
+
+c  Date et heure locale du debut du run
+c  ------------------------------------
+c    Date (en sols depuis le solstice de printemps) du debut du run
+      day0 = 0
+      PRINT *,'date de depart ?'
+      READ(unit,*) day0
+      day=float(day0)
+      PRINT *,day0
+c  Heure de demarrage
+      PRINT *,'heure de debut de simulation (entre 0 et 24) ?'
+      READ(unit,*) time
+      time=time/24.E+0
+
+c  Discretisation (Definition de la grille et des pas de temps)
+c  --------------
+c
+      nlayer=nlayermx
+      nlevel=nlayer+1
+      nsoil=nsoilmx
+      PRINT *,'nombre de pas de temps par jour ?'
+      READ(unit,*) day_step
+      print*,day_step
+
+      PRINT *,'nombre de jours simules ?'
+      READ(unit,*) ndt
+      print*,ndt
+
+      ndt=ndt*day_step     
+      dtphys=daysec/day_step  
+c Pression de surface sur la planete
+c ------------------------------------
+c
+      PRINT *,'pression au sol'
+      READ(unit,*) psurf
+      PRINT *,psurf
+c Pression de reference
+      pa=20.
+      preff=610.      
+ 
+c Proprietes des poussiere aerosol
+c --------------------------------
+      print *,'epaisseur optique dans le visible ?'
+      READ(unit,*) tauvis
+      print *,tauvis
+ 
+c  latitude/longitude
+c  ------------------
+      PRINT *,'latitude en degres ?'
+      READ(unit,*) lati(1)
+      PRINT *,lati(1)
+      lati(1)=lati(1)*pi/180.E+0
+      long(1)=0.E+0
+      long(1)=long(1)*pi/180.E+0
+
+c  Initialisation albedo / inertie du sol
+c  --------------------------------------
+c
+      PRINT *,'Albedo du sol nu ?'
+      READ(unit,*) albedodat(1)
+      PRINT *,albedodat(1)
+
+      PRINT *,'Inertie thermique du sol ?'
+      READ(unit,*) inertiedat(1)
+      PRINT *,inertiedat(1)
+c
+c  pour le schema d'ondes de gravite
+c  ---------------------------------
+c
+      zmea(1)=0.E+0
+      zstd(1)=0.E+0
+      zsig(1)=0.E+0
+      zgam(1)=0.E+0
+      zthe(1)=0.E+0
+
+
+
+c   Initialisation speciales "physiq"
+c   ---------------------------------
+c   la surface de chaque maille est inutile en 1D --->
+      area(1)=1.E+0
+
+c   le geopotentiel au sol est inutile en 1D car tout est controle
+c   par la pression de surface --->
+      phisfi(1)=0.E+0
+
+c  "inifis" reproduit un certain nombre d'initialisations deja faites
+c  + lecture des clefs de callphys.def
+c  + calcul de la frequence d'appel au rayonnement
+c  + calcul des sinus et cosinus des longitude latitude
+
+!Mars possible matter with dtphys in input and include!!!
+      CALL inifis(1,llm,day0,daysec,dtphys,
+     .            lati,long,area,rad,g,r,cpp)
+c   Initialisation pour prendre en compte les vents en 1-D
+c   ------------------------------------------------------
+      ptif=2.E+0*omeg*sinlat(1)
+ 
+c    vent geostrophique
+      PRINT *,'composante vers l est du vent geostrophique (U) ?'
+      READ(unit,*) gru
+      PRINT *,'composante vers le nord du vent geostrophique (V) ?'
+      READ(unit,*) grv
+
+c     Initialisation des vents  au premier pas de temps
+      DO ilayer=1,nlayer
+         u(ilayer)=gru
+         v(ilayer)=grv
+      ENDDO
+
+c     energie cinetique turbulente
+      DO ilevel=1,nlevel
+         q2(ilevel)=0.E+0
+      ENDDO
+
+c  glace de CO2 au sol
+c  -------------------
+      co2ice=0.E+0
+      PRINT *,'co2ice (kg.m-2)'
+      READ(unit,*) co2ice
+
+c
+c  emissivite
+c  ----------
+      emis=emissiv
+      IF (co2ice.eq.1.E+0) THEN
+         emis=emisice(1)
+         IF(lati(1).LT.0) emis=emisice(2)
+      ENDIF
+
+ 
+
+c  calcul des pressions et altitudes en utilisant les niveaux sigma
+c  ----------------------------------------------------------------
+
+c    Vertical Coordinates
+c    """"""""""""""""""""
+      PRINT *,'Hybrid coordinates ?'
+      READ(unit,*) hybrid
+      PRINT *,'Hybrid =', hybrid
+
+      CALL  disvert
+
+      DO ilevel=1,nlevel
+        plev(ilevel)=ap(ilevel)+psurf*bp(ilevel)
+      ENDDO
+
+      DO ilayer=1,nlayer
+        play(ilayer)=aps(ilayer)+psurf*bps(ilayer)
+      ENDDO
+
+      DO ilayer=1,nlayer
+        zlay(ilayer)=-200.E+0 *r*log(play(ilayer)/plev(1))
+     &   /g
+      ENDDO
+
+
+c  profil de temperature au premier appel
+c  --------------------------------------
+      pks=psurf**rcp
+
+c altitude en km dans profile: on divise zlay par 1000
+      tmp1(0)=0.E+0
+      DO ilayer=1,nlayer
+        tmp1(ilayer)=zlay(ilayer)/1000.E+0
+      ENDDO
+      call profile(unit,nlayer+1,tmp1,tmp2)
+
+      tsurf=tmp2(0)
+      DO ilayer=1,nlayer
+        temp(ilayer)=tmp2(ilayer)
+      ENDDO
+      
+
+
+c     temperature du sous-sol
+c     ~~~~~~~~~~~~~~~~~~~~~~~
+      DO isoil=1,nsoil
+         tsoil(isoil)=tsurf
+      ENDDO
+
+c    Initialisation des traceurs
+c    ---------------------------
+
+      DO iq=1,nqmx
+        DO ilayer=1,nlayer
+           q(ilayer,iq) = 0.
+        ENDDO
+      ENDDO
+
+      if (photochem.or.callthermos) then
+         write(*,*) 'Especes chimiques initialisees'
+         ! thermo=0: initialisation pour toutes les couches 
+         thermo=0
+         call inichim_newstart(q,psurf,sig,nqmx,lati,long,area,
+     $   thermo)
+      endif
+      watercaptag(ngridmx)=.false.
+      
+      DO iq=1,nqmx-1
+        qsurf(iq) = 0.
+      ENDDO
+
+
+c    Initialisation pour les sorties GRADS dans "g1d.dat" et "g1d.ctl"
+c    ----------------------------------------------------------------
+c    (effectuee avec "writeg1d" a partir de "physiq.F"
+c    ou tout autre subroutine physique, y compris celle ci).
+
+        g1d_nlayer=nlayer
+        g1d_nomfich='g1d.dat'
+        g1d_unitfich=40
+        g1d_nomctl='g1d.ctl'
+        g1d_unitctl=41
+        g1d_premier=.true.
+        g2d_premier=.true.
+
+c  Ecriture de "startfi"
+c  --------------------
+c  (Ce fichier sera aussitot relu au premier
+c   appel de "physiq", mais il est necessaire pour passer
+c   les variables purement physiques a "physiq"...
+
+      call physdem1("startfi.nc",long,lati,nsoilmx,nqmx,
+     .              dtphys,float(day0),
+     .              time,tsurf,tsoil,co2ice,emis,q2,qsurf,
+     .              area,albedodat,inertiedat,zmea,zstd,zsig,zgam,zthe)
+c=======================================================================
+c  BOUCLE TEMPORELLE DU MODELE 1D 
+c=======================================================================
+c
+      firstcall=.true.
+      lastcall=.false.
+
+      DO idt=1,ndt
+c        IF (idt.eq.ndt) lastcall=.true.
+        IF (idt.eq.ndt-day_step-1) then       !test
+         lastcall=.true.
+         call solarlong(day*1.0,zls)
+         write(103,*) 'Ls=',zls*180./pi
+         write(103,*) 'Lat=', lati(1)*180./pi
+         write(103,*) 'Tau=', tauvis/700*psurf
+         write(103,*) 'RunEnd - Atmos. Temp. File'
+         write(103,*) 'RunEnd - Atmos. Temp. File'
+         write(104,*) 'Ls=',zls*180./pi
+         write(104,*) 'Lat=', lati(1)
+         write(104,*) 'Tau=', tauvis/700*psurf
+         write(104,*) 'RunEnd - Atmos. Temp. File'
+        ENDIF
+
+c    calcul du geopotentiel 
+c     ~~~~~~~~~~~~~~~~~~~~~
+      DO ilayer=1,nlayer
+        s(ilayer)=(aps(ilayer)/psurf+bps(ilayer))**rcp
+        h(ilayer)=cpp*temp(ilayer)/(pks*s(ilayer))
+      ENDDO
+      phi(1)=pks*h(1)*(1.E+0-s(1))
+      DO ilayer=2,nlayer
+         phi(ilayer)=phi(ilayer-1)+
+     &               pks*(h(ilayer-1)+h(ilayer))*.5E+0
+     &                  *(s(ilayer-1)-s(ilayer))
+
+      ENDDO
+
+c       appel de la physique
+c       --------------------
+
+      CALL physiq (1,llm,nqmx,
+     ,     firstcall,lastcall,
+     ,     day,time,dtphys,
+     ,     plev,play,phi,
+     ,     u, v,temp, q,  
+     ,     w,
+C - sorties
+     s     du, dv, dtemp, dq,dpsurf,tracerdyn)
+
+c       evolution du vent : modele 1D
+c       -----------------------------
+ 
+c       la physique calcule les derivees temporelles de u et v.
+c       on y rajoute betement un effet Coriolis.
+c
+c       DO ilayer=1,nlayer
+c          du(ilayer)=du(ilayer)+ptif*(v(ilayer)-grv)
+c          dv(ilayer)=dv(ilayer)+ptif*(-u(ilayer)+gru)
+c       ENDDO
+
+c       Pour certain test : pas de coriolis a l'equateur
+c       if(lati(1).eq.0.) then
+          DO ilayer=1,nlayer
+             du(ilayer)=du(ilayer)+ (gru-u(ilayer))/1.e4
+             dv(ilayer)=dv(ilayer)+ (grv-v(ilayer))/1.e4
+          ENDDO
+c       end if
+c      
+c
+c       Calcul du temps au pas de temps suivant
+c       ---------------------------------------
+        firstcall=.false.
+        time=time+dtphys/daysec
+        IF (time.gt.1.E+0) then
+            time=time-1.E+0
+            day=day+1
+        ENDIF
+
+c       calcul des vitesses et temperature au pas de temps suivant
+c       ----------------------------------------------------------
+
+        DO ilayer=1,nlayer
+           u(ilayer)=u(ilayer)+dtphys*du(ilayer)
+           v(ilayer)=v(ilayer)+dtphys*dv(ilayer)
+           temp(ilayer)=temp(ilayer)+dtphys*dtemp(ilayer)
+        ENDDO
+
+c       calcul des pressions au pas de temps suivant
+c       ----------------------------------------------------------
+
+           psurf=psurf+dtphys*dpsurf   ! evolution de la pression de surface
+           DO ilevel=1,nlevel
+             plev(ilevel)=ap(ilevel)+psurf*bp(ilevel)
+           ENDDO
+           DO ilayer=1,nlayer
+             play(ilayer)=aps(ilayer)+psurf*bps(ilayer)
+           ENDDO
+
+      ENDDO   ! fin de la boucle temporelle
+
+c    ========================================================
+c    GESTION DES SORTIE
+c    ========================================================
+
+c    fermeture pour conclure les sorties format grads dans "g1d.dat"
+c    et "g1d.ctl" (effectuee avec "writeg1d" a partir de "physiq.F"
+c    ou tout autre subroutine physique, y compris celle ci).
+
+c        CALL endg1d(1,nlayer,zphi/(g*1000.),ndt)
+        CALL endg1d(1,nlayer,zlay/1000.,ndt)
+
+c    ========================================================
+      END
+ 
+c***********************************************************************
+c***********************************************************************
+c     Subroutines Bidons utilise seulement en 3D, mais
+c     necessaire a la compilation de testphys1d en 1-D
+
+      subroutine gr_fi_dyn
+      RETURN
+      END
+ 
+      subroutine iniwrite
+      RETURN
+      END
+ 
+c***********************************************************************
+c***********************************************************************
+
+#include "../dyn3d/disvert.F"
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tracer.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tracer.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/tracer.h	(revision 57)
@@ -0,0 +1,23 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'tracer.h'
+
+      character*10  noms(nqmx)  ! name of the tracer
+      real mmol(nqmx)           ! mole mass of tracer (g/mol-1) 
+      real radius(nqmx)   ! dust and ice particle radius (m)
+	  real rho_q(nqmx)    ! tracer densities (kg.m-3)
+      real qext(nqmx)     ! Single Scat. Extinction coeff at 0.67 um
+      real alpha_lift(nqmx) ! saltation vertical flux/horiz flux ratio (m-1)
+      real alpha_devil(nqmx) ! lifting coeeficient by dust devil
+
+      real varian      ! Characteristic variance of log-normal distribution
+      real r3n_q     ! used to compute r0 from number and mass mixing ratio
+      real qextrhor(nqmx) ! Intermediate for computing opt. depth from q
+      real rho_dust     ! Mars dust density (kg.m-3)
+      real rho_ice     ! Water ice density (kg.m-3)
+      real ref_r0        ! for computing reff=ref_r0*r0 (in log.n. distribution)
+
+      real dryness(ngridmx)!"Dryness coefficient" for grnd water ice sublimation
+      
+      COMMON/tracer/radius,rho_q,qext,alpha_lift,alpha_devil,noms,mmol,
+     & varian,r3n_q,qextrhor,rho_dust,rho_ice,ref_r0,dryness
+c-----------------------------------------------------------------------
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_cd.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_cd.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_cd.F	(revision 57)
@@ -0,0 +1,116 @@
+      SUBROUTINE vdif_cd( ngrid,nlay,pz0,pg,pz,pu,pv,pts,ph,pcdv,pcdh)
+      IMPLICIT NONE
+c=======================================================================
+c
+c   Subject: computation of the surface drag coefficient using the
+c   -------  approch developed by Loui for ECMWF.
+c
+c   Author: Frederic Hourdin  15 /10 /93
+c   -------
+c
+c   Arguments:
+c   ----------
+c
+c   inputs:
+c   ------
+c     ngrid            size of the horizontal grid
+c     pg               gravity (m s -2)
+c     pz(ngrid)        height of the first atmospheric layer
+c     pu(ngrid)        u component of the wind in that layer
+c     pv(ngrid)        v component of the wind in that layer
+c     pts(ngrid)       surfacte temperature
+c     ph(ngrid)        potential temperature T*(p/ps)^kappa
+c
+c   outputs:
+c   --------
+c     pcdv(ngrid)      Cd for the wind
+c     pcdh(ngrid)      Cd for potential temperature
+c
+c=======================================================================
+c
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+c   Arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL pz0
+      REAL pg,pz(ngrid,nlay)
+      REAL pu(ngrid,nlay),pv(ngrid,nlay)
+      REAL pts(ngrid,nlay),ph(ngrid,nlay)
+      REAL pcdv(ngrid),pcdh(ngrid)
+
+c   Local:
+c   ------
+
+      INTEGER ig
+
+      REAL zu2,z1,zri,zcd0,zz
+
+      REAL karman,b,c,d,c2b,c3bc,c3b,umin2
+      LOGICAL firstcal
+      DATA karman,b,c,d,umin2/.4,5.,5.,5.,1.e-12/
+      DATA firstcal/.true./
+      SAVE b,c,d,karman,c2b,c3bc,c3b,firstcal,umin2
+
+c-----------------------------------------------------------------------
+c   couche de surface:
+c   ------------------
+
+c     DO ig=1,ngrid
+c        zu2=pu(ig)*pu(ig)+pv(ig)*pv(ig)+umin2
+c        pcdv(ig)=pz0*(1.+sqrt(zu2))
+c        pcdh(ig)=pcdv(ig)
+c     ENDDO
+c     RETURN
+c
+c      IF (firstcal) THEN
+c         c2b=2.*b
+c         c3bc=3.*b*c
+c         c3b=3.*b
+c         firstcal=.false.
+c      ENDIF
+c
+c!!!! WARNING, verifier la formule originale de Louis!
+c      DO ig=1,ngrid
+c         zu2=pu(ig)*pu(ig)+pv(ig)*pv(ig)+umin2
+c         zri=pg*pz(ig)*(ph(ig)-pts(ig))/(ph(ig)*zu2)
+c._.
+c            zri=0.E+0
+c._.
+c         z1=1.+pz(ig)/pz0
+c         zcd0=karman/log(z1)
+c._.         zcd0=zcd0*zcd0*sqrt(zu2)
+c         zcd0=zcd0*zcd0
+c         IF(zri.LT.0.) THEN
+c._.            z1=b*zri/(1.+c3bc*zcd0*sqrt(-z1*zri))
+c            z1=b*zri/(1.+c3bc*zcd0*sqrt(-z1*zri*zu2))
+c            pcdv(ig)=zcd0*(1.-2.*z1)
+c            pcdh(ig)=zcd0*(1.-3.*z1)
+c         ELSE
+c            zz=sqrt(1.+d*zri)
+c            pcdv(ig)=zcd0/(1.+c2b*zri/zz)
+c            pcdh(ig)=zcd0/(1.+c3b*zri*zz)
+c         ENDIF
+c      ENDDO
+
+
+c On calcule un VRAI cdrag tout bete
+
+      DO ig=1,ngrid
+         z1=1.E+0 + pz(ig,1)/pz0
+         zcd0=karman/log(z1)
+         zcd0=zcd0*zcd0
+         pcdv(ig)=zcd0
+         pcdh(ig)=zcd0
+      ENDDO
+
+       
+
+
+c-----------------------------------------------------------------------
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_kc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_kc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdif_kc.F	(revision 57)
@@ -0,0 +1,554 @@
+      SUBROUTINE vdif_kc(dt,g,zlev,zlay,u,v,teta,cd,q2,km,kn)
+      IMPLICIT NONE
+c.......................................................................
+#include "dimensions.h"
+#include "dimphys.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      REAL dt,g
+      REAL zlev(ngridmx,nlayermx+1)
+      REAL zlay(ngridmx,nlayermx)
+      REAL u(ngridmx,nlayermx)
+      REAL v(ngridmx,nlayermx)
+      REAL teta(ngridmx,nlayermx)
+      REAL cd(ngridmx)
+      REAL q2(ngridmx,nlayermx+1)
+      REAL km(ngridmx,nlayermx+1)
+      REAL kn(ngridmx,nlayermx+1)
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(ngridmx,nlayermx)
+      REAL unsdzdec(ngridmx,nlayermx+1)
+      REAL q(ngridmx,nlayermx+1)
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(ngridmx,nlayermx+1)
+      REAL qcstat
+      REAL q2cstat
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(ngridmx,nlayermx+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(ngridmx,nlayermx+1)
+      REAL mpre(ngridmx,nlayermx+1)
+      REAL m2(ngridmx,nlayermx+1)
+      REAL n2(ngridmx,nlayermx+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(ngridmx,nlayermx+1)
+      REAL sn(ngridmx,nlayermx+1)
+      REAL snq2(ngridmx,nlayermx+1)
+      REAL sm(ngridmx,nlayermx+1)
+      REAL smq2(ngridmx,nlayermx+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long0 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL kappa
+      REAL long0
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL q2min
+      REAL q2max
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL knmin
+      REAL kmmin
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long0=160.E+0)
+      PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.E-3)
+      PARAMETER (q2max=1.E+2)
+      PARAMETER (nlay=nlayermx)
+      PARAMETER (nlev=nlayermx+1)
+      PARAMETER (ngrid=ngridmx)
+c
+      PARAMETER (
+     &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)
+     &          -3.E+0 *c1*(b2+6.E+0 *a1)))
+     &          )
+      PARAMETER (
+     &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm4=-9.E+0 *a1*a2
+     &          )
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+c                                                     DO igrid=1,ngrid 
+c           zlev(igrid,nlev)=zlay(igrid,nlay)
+c    &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+c                                                     ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0)
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid 
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+
+c
+c.......................................................................
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdifc.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdifc.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vdifc.F	(revision 57)
@@ -0,0 +1,588 @@
+      SUBROUTINE vdifc(ngrid,nlay,nq,co2ice,ppopsk,
+     $                ptimestep,pcapcal,lecrit,
+     $                pplay,pplev,pzlay,pzlev,pz0,
+     $                pu,pv,ph,pq,ptsrf,pemis,pqsurf,
+     $                pdufi,pdvfi,pdhfi,pdqfi,pfluxsrf,
+     $                pdudif,pdvdif,pdhdif,pdtsrf,pq2,
+     $                pdqdif,pdqsdif)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   subject:
+c   --------
+c   Turbulent diffusion (mixing) for potential T, U, V and tracer
+c
+c   Shema implicite
+c   On commence par rajouter au variables x la tendance physique
+c   et on resoult en fait:
+c      x(t+1) =  x(t) + dt * (dx/dt)phys(t)  +  dt * (dx/dt)difv(t+1)
+c
+c   author:
+c   ------
+c      Hourdin/Forget/Fournier
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "surfdat.h"
+#include "comgeomfi.h"
+#include "tracer.h"
+
+#include "watercap.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay
+      REAL ptimestep
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      REAL pzlay(ngrid,nlay),pzlev(ngrid,nlay+1)
+      REAL pu(ngrid,nlay),pv(ngrid,nlay),ph(ngrid,nlay)
+      REAL ptsrf(ngrid),pemis(ngrid)
+      REAL pdufi(ngrid,nlay),pdvfi(ngrid,nlay),pdhfi(ngrid,nlay)
+      REAL pfluxsrf(ngrid)
+      REAL pdudif(ngrid,nlay),pdvdif(ngrid,nlay),pdhdif(ngrid,nlay)
+      REAL pdtsrf(ngrid),pcapcal(ngrid)
+      REAL pq2(ngrid,nlay+1)
+
+c    Argument added for condensation:
+      REAL co2ice (ngrid), ppopsk(ngrid,nlay)
+      logical lecrit
+      REAL pz0
+
+c    Traceurs :
+      integer nq 
+      REAL pqsurf(ngrid,nq)
+      real pq(ngrid,nlay,nq), pdqfi(ngrid,nlay,nq) 
+      real pdqdif(ngrid,nlay,nq) 
+      real pdqsdif(ngrid,nq) 
+      
+c   local:
+c   ------
+
+      INTEGER ilev,ig,ilay,nlev,ierr
+
+      REAL z4st,zdplanck(ngridmx)
+      REAL zkv(ngridmx,nlayermx+1),zkh(ngridmx,nlayermx+1)
+	  REAL zcdv(ngridmx),zcdh(ngridmx)
+	  REAL zcdv_true(ngridmx),zcdh_true(ngridmx)
+      REAL zu(ngridmx,nlayermx),zv(ngridmx,nlayermx)
+      REAL zh(ngridmx,nlayermx)
+      REAL ztsrf2(ngridmx)
+      REAL z1(ngridmx),z2(ngridmx)
+      REAL za(ngridmx,nlayermx),zb(ngridmx,nlayermx)
+      REAL zb0(ngridmx,nlayermx)
+      REAL zc(ngridmx,nlayermx),zd(ngridmx,nlayermx)
+      REAL zcst1
+      REAL zu2
+
+      EXTERNAL SSUM,SCOPY
+      REAL SSUM
+      LOGICAL firstcall
+      SAVE firstcall
+
+c     variable added for CO2 condensation:
+c     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+      REAL hh , zhcond(ngridmx,nlayermx), tconds
+       REAL latcond,tcond1mb
+      REAL acond,bcond
+      SAVE acond,bcond
+      DATA latcond,tcond1mb/5.9e5,136.27/
+
+c    Tracers :
+c    ~~~~~~~ 
+      INTEGER iq
+      REAL zq(ngridmx,nlayermx,nqmx)
+      REAL zq1temp(ngridmx)
+      REAL rho(ngridmx) ! near surface air density
+      REAL qsat(ngridmx)
+      DATA firstcall/.true./
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+         IF(ngrid.NE.ngridmx) THEN
+            PRINT*,'STOP dans coefdifv'
+            PRINT*,'probleme de dimensions :'
+            PRINT*,'ngrid  =',ngrid
+            PRINT*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+c        To compute: Tcond= 1./(bcond-acond*log(.0095*p)) (p in pascal)
+         bcond=1./tcond1mb
+         acond=r/latcond
+         PRINT*,'In vdifc: Tcond(P=1mb)=',tcond1mb,' Lcond=',latcond
+         PRINT*,'acond,bcond,ccond',acond,bcond,acond
+
+         firstcall=.false.
+      ENDIF
+
+
+
+
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+
+      nlev=nlay+1
+
+c    ** calcul de rho*dz et dt*rho/dz=dt*rho**2 g/dp
+c       avec rho=p/RT=p/ (R Theta) (p/ps)**kappa
+c       ----------------------------------------
+
+      DO ilay=1,nlay
+         DO ig=1,ngrid
+            za(ig,ilay)=(pplev(ig,ilay)-pplev(ig,ilay+1))/g
+         ENDDO
+      ENDDO
+
+      zcst1=4.*g*ptimestep/(r*r)
+      DO ilev=2,nlev-1
+         DO ig=1,ngrid
+            zb0(ig,ilev)=pplev(ig,ilev)*
+     s      (pplev(ig,1)/pplev(ig,ilev))**rcp /
+     s      (ph(ig,ilev-1)+ph(ig,ilev))
+            zb0(ig,ilev)=zcst1*zb0(ig,ilev)*zb0(ig,ilev)/
+     s      (pplay(ig,ilev-1)-pplay(ig,ilev))
+         ENDDO
+      ENDDO
+      DO ig=1,ngrid
+		 zb0(ig,1)=ptimestep*pplev(ig,1)/(r*ptsrf(ig))
+      ENDDO
+
+c    ** diagnostique pour l'initialisation
+c       ----------------------------------
+
+      IF(lecrit) THEN
+         ig=ngrid/2+1
+         PRINT*,'Pression (mbar) ,altitude (km),u,v,theta, rho dz'
+         DO ilay=1,nlay
+            WRITE(*,'(6f11.5)')
+     s      .01*pplay(ig,ilay),.001*pzlay(ig,ilay),
+     s      pu(ig,ilay),pv(ig,ilay),ph(ig,ilay),za(ig,ilay)
+         ENDDO
+         PRINT*,'Pression (mbar) ,altitude (km),zb'
+         DO ilev=1,nlay
+            WRITE(*,'(3f15.7)')
+     s      .01*pplev(ig,ilev),.001*pzlev(ig,ilev),
+     s      zb0(ig,ilev)
+         ENDDO
+      ENDIF
+
+c     Potential Condensation temperature:
+c     -----------------------------------
+
+c     if (callcond) then 
+c       DO ilev=1,nlay
+c         DO ig=1,ngrid
+c           zhcond(ig,ilev) =
+c    &  (1./(bcond-acond*log(.0095*pplay(ig,ilev))))/ppopsk(ig,ilev)
+c         END DO
+c       END DO
+c     else
+        call zerophys(ngrid*nlay,zhcond)
+c     end if
+
+
+c-----------------------------------------------------------------------
+c   2. ajout des tendances physiques
+c      -----------------------------
+
+      DO ilev=1,nlay
+         DO ig=1,ngrid
+            zu(ig,ilev)=pu(ig,ilev)+pdufi(ig,ilev)*ptimestep
+            zv(ig,ilev)=pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep
+            zh(ig,ilev)=ph(ig,ilev)+pdhfi(ig,ilev)*ptimestep
+            zh(ig,ilev)=max(zh(ig,ilev),zhcond(ig,ilev))
+         ENDDO
+      ENDDO
+      if(tracer) then
+        DO iq =1, nq
+         DO ilev=1,nlay
+           DO ig=1,ngrid
+              zq(ig,ilev,iq)=pq(ig,ilev,iq)+pdqfi(ig,ilev,iq)*ptimestep
+           ENDDO
+         ENDDO
+        ENDDO
+      end if
+
+c-----------------------------------------------------------------------
+c   3. schema de turbulence
+c      --------------------
+
+c    ** source d'energie cinetique turbulente a la surface
+c       (condition aux limites du schema de diffusion turbulente
+c       dans la couche limite
+c       ---------------------
+
+      CALL vdif_cd( ngrid,nlay,pz0,g,pzlay,pu,pv,ptsrf,ph
+     &             ,zcdv_true,zcdh_true)
+      DO ig=1,ngrid
+        zu2=pu(ig,1)*pu(ig,1)+pv(ig,1)*pv(ig,1)
+        zcdv(ig)=zcdv_true(ig)*sqrt(zu2)
+        zcdh(ig)=zcdh_true(ig)*sqrt(zu2)
+      ENDDO
+
+c    ** schema de diffusion turbulente dans la couche limite
+c       ---------------------------------------------------- 
+
+        CALL vdif_kc(ptimestep,g,pzlev,pzlay
+     &              ,pu,pv,ph,zcdv_true
+     &              ,pq2,zkv,zkh)
+
+
+
+c    ** diagnostique pour le schema de turbulence
+c       -----------------------------------------
+
+      IF(lecrit) THEN
+         PRINT*
+         PRINT*,'Diagnostic for the vertical turbulent mixing'
+         PRINT*,'Cd for momentum and potential temperature'
+
+         PRINT*,zcdv(ngrid/2+1),zcdh(ngrid/2+1)
+         PRINT*,'Mixing coefficient for momentum and pot.temp.'
+         DO ilev=1,nlay
+            PRINT*,zkv(ngrid/2+1,ilev),zkh(ngrid/2+1,ilev)
+         ENDDO
+      ENDIF
+
+
+
+
+c-----------------------------------------------------------------------
+c   4. inversion pour l'implicite sur u
+c      --------------------------------
+
+c    ** l'equation est 
+c       u(t+1) =  u(t) + dt * {(du/dt)phys}(t)  +  dt * {(du/dt)difv}(t+1)
+c       avec
+c       /zu/ = u(t) + dt * {(du/dt)phys}(t)   (voir paragraphe 2.)
+c       et
+c       dt * {(du/dt)difv}(t+1) = dt * {(d/dz)[ Ku (du/dz) ]}(t+1)
+c       donc les entrees sont /zcdv/ pour la condition a la limite sol
+c       et /zkv/ = Ku
+ 
+      CALL multipl((nlay-1)*ngrid,zkv(1,2),zb0(1,2),zb(1,2))
+      CALL multipl(ngrid,zcdv,zb0,zb)
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zu(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $         zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zu(ig,ilay)+
+     $         zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zu(ig,1)=zc(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zu(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*zu(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+
+
+
+
+c-----------------------------------------------------------------------
+c   5. inversion pour l'implicite sur v
+c      --------------------------------
+
+c    ** l'equation est 
+c       v(t+1) =  v(t) + dt * {(dv/dt)phys}(t)  +  dt * {(dv/dt)difv}(t+1)
+c       avec
+c       /zv/ = v(t) + dt * {(dv/dt)phys}(t)   (voir paragraphe 2.)
+c       et
+c       dt * {(dv/dt)difv}(t+1) = dt * {(d/dz)[ Kv (dv/dz) ]}(t+1)
+c       donc les entrees sont /zcdv/ pour la condition a la limite sol
+c       et /zkv/ = Kv
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zv(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $         zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zv(ig,ilay)+
+     $         zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+      DO ig=1,ngrid
+         zv(ig,1)=zc(ig,1)
+      ENDDO
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            zv(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*zv(ig,ilay-1)
+         ENDDO
+      ENDDO
+
+
+
+
+
+c-----------------------------------------------------------------------
+c   6. inversion pour l'implicite sur h sans oublier le couplage
+c      avec le sol (conduction)
+c      ------------------------
+
+c    ** l'equation est 
+c       h(t+1) =  h(t) + dt * {(dh/dt)phys}(t)  +  dt * {(dh/dt)difv}(t+1)
+c       avec
+c       /zh/ = h(t) + dt * {(dh/dt)phys}(t)   (voir paragraphe 2.)
+c       et
+c       dt * {(dh/dt)difv}(t+1) = dt * {(d/dz)[ Kh (dh/dz) ]}(t+1)
+c       donc les entrees sont /zcdh/ pour la condition de raccord au sol
+c       et /zkh/ = Kh
+c       -------------
+
+      CALL multipl((nlay-1)*ngrid,zkh(1,2),zb0(1,2),zb(1,2))
+      CALL multipl(ngrid,zcdh,zb0,zb)
+
+      DO ig=1,ngrid
+         z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+         zc(ig,nlay)=za(ig,nlay)*zh(ig,nlay)*z1(ig)
+         zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+      ENDDO
+
+      DO ilay=nlay-1,1,-1
+         DO ig=1,ngrid
+            z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $         zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+            zc(ig,ilay)=(za(ig,ilay)*zh(ig,ilay)+
+     $         zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+            zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+         ENDDO
+      ENDDO
+
+c    ** calcul de (d Planck / dT) a la temperature d'interface
+c       ------------------------------------------------------
+
+      z4st=4.*5.67e-8*ptimestep
+      DO ig=1,ngrid
+         zdplanck(ig)=z4st*pemis(ig)*ptsrf(ig)*ptsrf(ig)*ptsrf(ig)
+      ENDDO
+
+c    ** calcul de la temperature_d'interface et de sa tendance.
+c       on ecrit que la somme des flux est nulle a l'interface
+c       a t + \delta t,
+c       c'est a dire le flux radiatif a {t + \delta t}
+c       + le flux turbulent a {t + \delta t} 
+c            qui s'ecrit K (T1-Tsurf) avec T1 = d1 Tsurf + c1
+c            (notation K dt = /cpp*b/)        
+c       + le flux dans le sol a t
+c       + l'evolution du flux dans le sol lorsque la temperature d'interface
+c       passe de sa valeur a t a sa valeur a {t + \delta t}.
+c       ----------------------------------------------------
+
+      DO ig=1,ngrid
+         z1(ig)=pcapcal(ig)*ptsrf(ig)+cpp*zb(ig,1)*zc(ig,1)
+     s     +zdplanck(ig)*ptsrf(ig)+ pfluxsrf(ig)*ptimestep
+         z2(ig)= pcapcal(ig)+cpp*zb(ig,1)*(1.-zd(ig,1))+zdplanck(ig)
+         ztsrf2(ig)=z1(ig)/z2(ig)
+         pdtsrf(ig)=(ztsrf2(ig)-ptsrf(ig))/ptimestep
+
+c        Modif speciale CO2 condensation:
+c        tconds = 1./(bcond-acond*log(.0095*pplev(ig,1)))
+c        if ((callcond).and.
+c    &      ((co2ice(ig).ne.0).or.(ztsrf2(ig).lt.tconds)))then
+c           zh(ig,1)=zc(ig,1)+zd(ig,1)*tconds
+c        else
+            zh(ig,1)=zc(ig,1)+zd(ig,1)*ztsrf2(ig)
+c        end if
+      ENDDO
+
+c    ** et a partir de la temperature au sol on remonte 
+c       -----------------------------------------------
+
+      DO ilay=2,nlay
+         DO ig=1,ngrid
+            hh = max( zh(ig,ilay-1) , zhcond(ig,ilay-1) ) ! modif co2cond
+            zh(ig,ilay)=zc(ig,ilay)+zd(ig,ilay)*hh
+         ENDDO
+      ENDDO
+
+
+c-----------------------------------------------------------------------
+c   TRACERS
+c   -------
+
+      if(tracer) then
+
+c     Using the wind modified by friction for lifting and  sublimation
+c     ----------------------------------------------------------------
+        DO ig=1,ngrid
+          zu2=zu(ig,1)*zu(ig,1)+zv(ig,1)*zv(ig,1)
+          zcdv(ig)=zcdv_true(ig)*sqrt(zu2)
+          zcdh(ig)=zcdh_true(ig)*sqrt(zu2)
+        ENDDO
+
+c       Calcul du flux vertical au bas de la premiere couche (dust) :
+c       -----------------------------------------------------------
+        do ig=1,ngridmx  
+          rho(ig) = zb0(ig,1) /ptimestep
+          zb(ig,1) = 0.
+        end do
+c       Dust lifting:
+        if (lifting) then 
+           call dustlift(ngrid,nlay,nq,rho,zcdh_true,zcdh,co2ice,
+     $                  pdqsdif)
+       
+           else
+           call zerophys(ngrid*nq,pdqsdif)
+        end if
+
+c       OU calcul de la valeur de q a la surface (water)  :
+c       ----------------------------------------
+        if (water) then 
+            call watersat(ngridmx,ptsrf,pplev(1,1),qsat)
+        end if
+
+c      Inversion pour l'implicite sur q 
+c       --------------------------------
+        do iq=1,nq
+          CALL multipl((nlay-1)*ngrid,zkh(1,2),zb0(1,2),zb(1,2))
+
+          if ((water).and.(iq.eq.nqmx)) then 
+c            This line is required to account for turbulent transport 
+c            from surface (e.g. ice) to mid-layer of atmosphere:
+             CALL multipl(ngrid,zcdv,zb0,zb(1,1))
+             CALL multipl(ngrid,dryness,zb(1,1),zb(1,1)) 
+          end if
+
+          DO ig=1,ngrid
+               z1(ig)=1./(za(ig,nlay)+zb(ig,nlay))
+               zc(ig,nlay)=za(ig,nlay)*zq(ig,nlay,iq)*z1(ig)
+               zd(ig,nlay)=zb(ig,nlay)*z1(ig)
+          ENDDO
+  
+          DO ilay=nlay-1,2,-1
+               DO ig=1,ngrid
+                z1(ig)=1./(za(ig,ilay)+zb(ig,ilay)+
+     $           zb(ig,ilay+1)*(1.-zd(ig,ilay+1)))
+                zc(ig,ilay)=(za(ig,ilay)*zq(ig,ilay,iq)+
+     $           zb(ig,ilay+1)*zc(ig,ilay+1))*z1(ig)
+                zd(ig,ilay)=zb(ig,ilay)*z1(ig)
+               ENDDO
+          ENDDO
+          DO ig=1,ngrid
+                z1(ig)=1./(za(ig,1)+zb(ig,1)+
+     $           zb(ig,2)*(1.-zd(ig,2)))
+                zc(ig,1)=(za(ig,1)*zq(ig,1,iq)+
+     $         zb(ig,2)*zc(ig,2) +
+     $        (-pdqsdif(ig,iq)) *ptimestep) *z1(ig)  !tracer flux from surface
+          ENDDO
+  
+          IF ((water).and.(iq.eq.nqmx)) then 
+c           Calculation for turbulent exchange with the surface (for ice)
+            DO ig=1,ngrid
+              zd(ig,1)=zb(ig,1)*z1(ig)
+              zq1temp(ig)=zc(ig,1)+ zd(ig,1)*qsat(ig)
+
+              pdqsdif(ig,nq)=rho(ig)*dryness(ig)*zcdv(ig)
+     &                       *(zq1temp(ig)-qsat(ig))
+c             write(*,*)'flux vers le sol=',pdqsdif(ig,nq)
+            END DO
+            DO ig=1,ngrid
+              if(.not.watercaptag(ig)) then
+              if ((-pdqsdif(ig,nq)*ptimestep).gt.pqsurf(ig,nq)) then
+c                 write(*,*)'on sublime plus que qsurf!'
+                  pdqsdif(ig,nq) = -pqsurf(ig,nq)/ptimestep
+c                 write(*,*)'flux vers le sol=',pdqsdif(ig,nq)
+                  z1(ig)=1./(za(ig,1)+ zb(ig,2)*(1.-zd(ig,2)))
+                  zc(ig,1)=(za(ig,1)*zq(ig,1,iq)+
+     $            zb(ig,2)*zc(ig,2) +
+     $            (-pdqsdif(ig,iq)) *ptimestep) *z1(ig)
+                  zq1temp(ig)=zc(ig,1)
+              endif   
+              endif   
+c             Starting upward calculations for water :
+               zq(ig,1,iq)=zq1temp(ig)
+            ENDDO
+          ELSE
+c           Starting upward calculations for simple mixing of tracer (dust)
+            DO ig=1,ngrid
+               zq(ig,1,iq)=zc(ig,1)
+            ENDDO
+          END IF
+
+          DO ilay=2,nlay
+             DO ig=1,ngrid
+                zq(ig,ilay,iq)=zc(ig,ilay)+zd(ig,ilay)*zq(ig,ilay-1,iq)
+             ENDDO
+          ENDDO
+        enddo
+      end if
+
+c-----------------------------------------------------------------------
+c   8. calcul final des tendances de la diffusion verticale
+c      ----------------------------------------------------
+
+      DO ilev = 1, nlay
+         DO ig=1,ngrid
+            pdudif(ig,ilev)=(    zu(ig,ilev)-
+     $      (pu(ig,ilev)+pdufi(ig,ilev)*ptimestep)    )/ptimestep
+            pdvdif(ig,ilev)=(    zv(ig,ilev)-
+     $      (pv(ig,ilev)+pdvfi(ig,ilev)*ptimestep)    )/ptimestep
+            hh = max(ph(ig,ilev)+pdhfi(ig,ilev)*ptimestep ,
+     $           zhcond(ig,ilev))        ! modif co2cond
+            pdhdif(ig,ilev)=( zh(ig,ilev)- hh )/ptimestep
+         ENDDO
+      ENDDO
+
+    
+      if (tracer) then 
+        DO iq = 1, nq
+          DO ilev = 1, nlay
+            DO ig=1,ngrid
+              pdqdif(ig,ilev,iq)=(zq(ig,ilev,iq)-
+     $      (pq(ig,ilev,iq) + pdqfi(ig,ilev,iq)*ptimestep))/ptimestep
+            ENDDO
+          ENDDO
+        ENDDO
+      end if
+
+c    ** diagnostique final 
+c       ------------------
+
+      IF(lecrit) THEN
+         PRINT*,'In vdif'
+         PRINT*,'Ts (t) and Ts (t+st)'
+         WRITE(*,'(a10,3a15)')
+     s   'theta(t)','theta(t+dt)','u(t)','u(t+dt)'
+         PRINT*,ptsrf(ngrid/2+1),ztsrf2(ngrid/2+1)
+         DO ilev=1,nlay
+            WRITE(*,'(4f15.7)')
+     s      ph(ngrid/2+1,ilev),zh(ngrid/2+1,ilev),
+     s      pu(ngrid/2+1,ilev),zu(ngrid/2+1,ilev)
+
+         ENDDO
+      ENDIF
+
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vlz_fi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vlz_fi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/vlz_fi.F	(revision 57)
@@ -0,0 +1,195 @@
+      SUBROUTINE vlz_fi(ngrid,q,pente_max,masse,w,wq)
+c
+c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
+c
+c    ********************************************************************
+c     Shema  d'advection " pseudo amont " dans la verticale
+c    pour appel dans la physique (sedimentation)
+c    ********************************************************************
+c    q rapport de melange (kg/kg)...
+c    masse : masse de la couche Dp/g
+c    w : masse d'atm ``transferee'' a chaque pas de temps (kg.m-2)
+c    pente_max = 2 conseillee
+c
+c
+c   --------------------------------------------------------------------
+      IMPLICIT NONE
+c
+#include "dimensions.h"
+#include "dimphys.h"
+
+c
+c
+c   Arguments:
+c   ----------
+      integer ngrid
+      real masse(ngrid,llm),pente_max
+      REAL q(ngrid,llm)
+      REAL w(ngrid,llm)
+      REAL wq(ngrid,llm+1)
+c
+c      Local 
+c   ---------
+c
+      INTEGER i,ij,l,j,ii
+c
+
+      real dzq(ngridmx,llm),dzqw(ngridmx,llm),adzqw(ngridmx,llm),dzqmax
+      real newmasse
+      real sigw, Mtot, MQtot
+      integer m
+
+      REAL      SSUM,CVMGP,CVMGT
+      integer ismax,ismin
+
+
+c    On oriente tout dans le sens de la pression c'est a dire dans le
+c    sens de W
+
+      do l=2,llm
+         do ij=1,ngrid
+            dzqw(ij,l)=q(ij,l-1)-q(ij,l)
+            adzqw(ij,l)=abs(dzqw(ij,l))
+         enddo
+      enddo
+
+      do l=2,llm-1
+         do ij=1,ngrid
+#ifdef CRAY
+            dzq(ij,l)=0.5*
+     ,      cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1))
+#else
+            if(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) then
+                dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1))
+            else
+                dzq(ij,l)=0.
+            endif
+#endif
+            dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1))
+            dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l))
+         enddo
+      enddo
+
+      do ij=1,ngrid
+         dzq(ij,1)=0.
+         dzq(ij,llm)=0.
+      enddo
+c ---------------------------------------------------------------
+c   .... calcul des termes d'advection verticale  .......
+c ---------------------------------------------------------------
+
+c calcul de  - d( q   * w )/ d(sigma)    qu'on ajoute a  dq pour calculer dq
+c
+c      No flux at the model top:
+       do ij=1,ngrid
+          wq(ij,llm+1)=0.
+       enddo
+
+c      1) Compute wq where w > 0 (down) (ALWAYS FOR SEDIMENTATION)     
+c      ===============================
+
+       do l = 1,llm          ! loop different than when w<0
+        do  ij = 1,ngrid
+
+         if(w(ij,l).gt.0.)then
+
+c         Regular scheme (transfered mass < 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(w(ij,l).le.masse(ij,l))then
+            sigw=w(ij,l)/masse(ij,l)
+            wq(ij,l)=w(ij,l)*(q(ij,l)+0.5*(1.-sigw)*dzq(ij,l))
+            
+
+c         Extended scheme (transfered mass > 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else 
+            m=l
+            Mtot = masse(ij,m)
+            MQtot = masse(ij,m)*q(ij,m)
+            if(m.ge.llm)goto 88
+            do while(w(ij,l).gt.(Mtot+masse(ij,m+1)))
+                m=m+1
+                Mtot = Mtot + masse(ij,m)
+                MQtot = MQtot + masse(ij,m)*q(ij,m)
+                if(m.ge.llm)goto 88
+            end do
+ 88         continue
+            if (m.lt.llm) then
+                sigw=(w(ij,l)-Mtot)/masse(ij,m+1)
+                wq(ij,l)=(MQtot + (w(ij,l)-Mtot)*
+     &          (q(ij,m+1)+0.5*(1.-sigw)*dzq(ij,m+1)) )
+            else
+                w(ij,l) = Mtot
+                wq(ij,l) = Mqtot 
+            end if
+          end if
+         end if
+        enddo
+       enddo
+
+c      2) Compute wq where w < 0 (up) (NOT USEFUL FOR SEDIMENTATION)     
+c      ===============================
+       goto 99 ! SKIPPING THIS PART FOR SEDIMENTATION 
+
+c      Surface flux up:
+       do  ij = 1,ngrid
+         if(w(ij,1).lt.0.) wq(ij,1)=0. ! warning : not always valid
+       end do
+
+       do l = 1,llm-1  ! loop different than when w>0
+        do  ij = 1,ngrid
+         if(w(ij,l+1).le.0)then
+
+c         Regular scheme (transfered mass < 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          if(-w(ij,l+1).le.masse(ij,l))then
+            sigw=w(ij,l+1)/masse(ij,l)
+            wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l))
+c         Extended scheme (transfered mass > 1 layer)
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          else 
+             m = l-1
+             Mtot = masse(ij,m+1)
+             MQtot = masse(ij,m+1)*q(ij,m+1)
+             if (m.le.0)goto 77
+             do while(-w(ij,l+1).gt.(Mtot+masse(ij,m)))
+                m=m-1
+                Mtot = Mtot + masse(ij,m+1)
+                MQtot = MQtot + masse(ij,m+1)*q(ij,m+1)
+                if (m.le.0)goto 77
+             end do
+ 77          continue
+
+             if (m.gt.0) then
+                sigw=(w(ij,l+1)+Mtot)/masse(ij,m)
+                wq(ij,l+1)= (MQtot + (-w(ij,l+1)-Mtot)*
+     &          (q(ij,m)-0.5*(1.+sigw)*dzq(ij,m))  )
+             else
+c               wq(ij,l+1)= (MQtot + (-w(ij,l+1)-Mtot)*qm(ij,1))
+                write(*,*) 'a rather weird situation in vlz_fi !'
+                stop
+             end if
+          endif
+         endif
+        enddo
+       enddo
+ 99    continue
+
+      do l=1,llm
+         do ij=1,ngrid
+
+cccccccc lines below not used for sedimentation (No real flux)
+ccccc       newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) 
+ccccc       q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l))
+ccccc&         /newmasse
+ccccc       masse(ij,l)=newmasse
+
+            q(ij,l)=q(ij,l) +  (wq(ij,l+1)-wq(ij,l))/masse(ij,l)
+
+         enddo
+      enddo
+
+
+
+      return
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercap.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercap.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercap.h	(revision 57)
@@ -0,0 +1,6 @@
+c-----------------------------------------------------------------------
+c INCLUDE 'watercap.h'
+
+      logical watercaptag(ngridmx)
+
+      common/permcap/watercaptag
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercloud.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercloud.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watercloud.F	(revision 57)
@@ -0,0 +1,409 @@
+       SUBROUTINE watercloud(ngrid,nlay, ptimestep, 
+     &      pplev,pplay,pdpsrf,pzlev,pzlay,pt,pdt,
+     &                pq,pdq,pdqcloud,qsurf,pdqscloud,pdtcloud,
+     &                nq,nsize,tau,icount,zls)
+      IMPLICIT NONE
+
+c=======================================================================
+c     Treatment of saturation of water vapor
+c
+c
+c     Modif de zq si saturation dans l'atmopshere
+c     si zq(ig,l)> zqsat(ig,l) ->    zq(ig,l)=zqsat(ig,l)
+c     Le test est effectue de bas en haut. L'eau condensee
+c    (si saturation) est remise dans la couche en dessous.
+c     L'eau condensee dans la couche du bas est deposee a la surface
+c
+c     WARNING : water vapor mixing ratio is assumed to be 
+c     q(nqmx)
+c       
+c    Modification: Franck Montmessin water ice scheme
+c                  Francois Forget : change nuclei density & outputs   
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "comcstfi.h"
+#include "callkeys.h"
+#include "tracer.h"
+
+#include "fisice.h"
+#include "comgeomfi.h"
+c
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,nsize
+      INTEGER icount
+      REAL ptimestep             ! pas de temps physique (s)
+      REAL pplev(ngrid,nlay+1)   ! pression aux inter-couches (Pa)
+      REAL pplay(ngrid,nlay)     ! pression au milieu des couches (Pa)
+      REAL pzlev(ngrid,nlay+1)   ! altitude at layer boundaries
+      REAL pzlay(ngrid,nlay)     ! altitude at the middle of the layers
+      REAL pdpsrf(ngrid)         ! tendance surf pressure
+      REAL pt(ngrid,nlay)        ! temperature au centre des couches (K)
+      REAL pdt(ngrid,nlay)       ! tendance temperature des autres param.
+      REAL pdtcloud(ngrid,nlay)  ! tendance temperature due a la chaleur latente
+      REAL tau(ngridmx,nsize)
+      REAL zls
+
+c    Traceurs :
+      integer nq                   ! nombre de traceurs 
+      real pq(ngrid,nlay,nq)       ! traceur (kg/kg)
+      real pdq(ngrid,nlay,nq)      ! tendance avant condensation  (kg/kg.s-1)
+      real pdqcloud(ngrid,nlay,nq) ! tendance de la condesation H2O(kg/kg.s-1)
+      real qsurf(ngrid,nq)
+      real pdqscloud(ngrid,nq)     ! flux en surface (kg.m-2.s-1)
+      
+c   local:
+c   ------
+
+      REAL CBRT
+      EXTERNAL CBRT
+      INTEGER ig,l
+
+      LOGICAL firstcall,improved
+      SAVE firstcall
+
+      REAL zq(ngridmx,nlayermx,nqmx)
+      REAL zq0(ngridmx,nlayermx,nqmx)
+      REAL zqsat(ngridmx,nlayermx)
+      REAL zt(ngridmx,nlayermx)
+
+
+      REAL masse (ngridmx,nlayermx)
+      REAL epaisseur (ngridmx,nlayermx)
+      REAL dustcores(ngridmx,nlayermx)  !Dust number density (#/kg) 
+      REAL rfinal        ! Ice crystal radius after condensation(m)
+      REAL seq           ! Equilibrium saturation ration (accounting for curvature effect)
+      REAL dzq           ! masse de glace echangee (kg/kg)
+      REAL lw       !Latent heat of sublimation (J.kg-1) 
+      REAL To
+
+      REAL Ctot
+      REAL*8 ph2o,satu
+      REAL gr,Cste,up,dwn,newvap
+
+      DATA firstcall/.true./
+      DATA improved/.false./      ! Actionne une microphysique plus raffinee
+
+c     Reference temperature, T=273,15 K
+      data To/273.15/
+
+      SAVE improved
+
+c     POur diagnostique :
+c     ~~~~~~~~~~~~~~~~~
+      REAL taucond(ngridmx,nlayermx)   ! taux de condensation (kg/kg/s-1)
+      REAL mtot(ngridmx)               ! Total mass of water vapor (kg/m2)
+      REAL icetot(ngridmx)             ! Total mass of water ice (kg/m2)
+      REAL rave(ngridmx)               ! Mean crystal radius in a column (m)
+      REAL cloudmass(ngridmx,nlayermx) ! mass of ice in each layer (kg/m2)
+      REAL op825(ngridmx,nlayermx)    ! abs optical depth at 825 cm-1
+      REAL tau825(ngridmx)    ! abs optical depth at 825 cm-1
+      REAL waterhem(2,3)
+      real a,b, Qabs 
+
+      REAL icetot2pm(ngridmx)
+      REAL mtot2pm(ngridmx)
+      REAL rave2pm(ngridmx)
+      REAL qsurf2pm(ngridmx)
+      INTEGER i,nit
+      REAL ecart,loctime
+      integer univtime,lon2pm(ngridmx)
+
+      integer ig_vl2
+      real latvl2,lonvl2
+
+      logical tesfield  ! output of TES like data
+      data tesfield /.false./
+
+c    ** un petit test de coherence
+c       --------------------------
+
+      IF (firstcall) THEN
+         IF(ngrid.NE.ngridmx) THEN
+            PRINT*,'STOP dans watercloud'
+            PRINT*,'probleme de dimensions :'
+            PRINT*,'ngrid  =',ngrid
+            PRINT*,'ngridmx  =',ngridmx
+            STOP
+         ENDIF
+         if(nq.gt.nqmx) then
+           write(*,*) 'stop in watercloud (nq.gt.nqmx)!'
+           write(*,*) 'nq=',nq,' nqmx=',nqmx
+           stop
+         endif
+         firstcall=.false.
+      ENDIF
+
+
+c-----------------------------------------------------------------------
+c    1. initialisation
+c    -----------------
+
+c    On "update" la valeur de q(nqmx) (water vapor) et temperature.
+c    On effectue qqes calculs preliminaires sur les couches : 
+c    masse (kg.m-2), epaisseur(m).
+
+      do l=1,nlay
+          do ig=1,ngrid
+            zq(ig,l,nq)=pq(ig,l,nq)+pdq(ig,l,nq)*ptimestep
+            zq(ig,l,nq)=max(zq(ig,l,nq),1.E-30) ! FF 12/2004 
+            zq0(ig,l,nq)=zq(ig,l,nq)
+            zt(ig,l)=pt(ig,l)+ pdt(ig,l)*ptimestep
+            masse(ig,l)=(pplev(ig,l) - pplev(ig,l+1)) /g
+            epaisseur(ig,l)= pzlev(ig,l+1) - pzlev(ig,l)
+            if(iceparty) then
+              zq(ig,l,nq-1)=pq(ig,l,nq-1)+pdq(ig,l,nq-1)*ptimestep
+              zq(ig,l,nq-1)=max(zq(ig,l,nq-1),0.) ! FF 12/2004 
+              zq0(ig,l,nq-1)=zq(ig,l,nq-1)
+              rdust(ig,l)= max(.8e-6*exp(-pzlay(ig,l)/18000.),1.e-9)
+c         Calcul du rayon moyen des particules de glace.
+c         Hypothese : Dans une couche, la glace presente se
+c         repartit uniformement autour du nbre de poussieres
+c         dont le rayon moyen est prescrit par rdust.
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+              if ((dustbin.eq.1).and..not.(doubleq)) then
+                zq(ig,l,1)=pq(ig,l,1)+pdq(ig,l,1)*ptimestep
+                dustcores(ig,l)=max(zq(ig,l,1)/
+     &           (rho_dust*4./3.*pi*radius(1)**3.),1.e-9)
+              else
+                dustcores(ig,l)=( epaisseur(ig,l)/masse(ig,l) ) *
+     &       2.e+6/0.1*max(tau(ig,1),0.001)*exp(-pzlay(ig,l)/10000.)
+
+c            TEMPORAIRE : réduction du nombre de nuclei FF 04/2008 :
+c               dustcores(ig,l) = dustcores(ig,l) / 27. ! reduction facteur 3
+                dustcores(ig,l) = dustcores(ig,l) / 8. ! reduction facteur 2
+              endif
+              rice(ig,l)=CBRT( ( zq(ig,l,nq-1)/rho_ice+
+     &         dustcores(ig,l)*(4./3.)*pi*rdust(ig,l)**3. )
+     &         / (dustcores(ig,l)*4./3.*pi) )
+              rice(ig,l)=max(rice(ig,l),rdust(ig,l))
+            endif
+          enddo
+      enddo
+
+      call zerophys(ngrid*nq,pdqscloud)
+      call zerophys(ngrid*nlay*nq,pdqcloud)
+      call zerophys(ngrid*nlay,pdtcloud)
+      call zerophys(ngrid,mtot)
+
+      call zerophys(ngrid,icetot)
+      call zerophys(ngrid,rave)
+      call zerophys(ngrid,cloudmass)
+
+c    ----------------------------------------------
+c
+c
+c       Rapport de melange a saturation dans la couche l : -------
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+        call watersat(ngridmx*nlayermx,zt,pplay,zqsat)
+
+c       taux de condensation (kg/kg/s-1) dans les differentes couches
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c       (Pour diagnostic seulement !)
+        if(.not.iceparty)then
+        do l=1, nlay
+          do ig=1,ngridmx
+            taucond(ig,l)= max((zq(ig,l,nq)-zqsat(ig,l))/ptimestep,0.)
+          end do
+        end do
+        endif
+
+
+        if(iceparty) then
+          do l=1,nlay
+            do ig=1,ngrid
+
+            If (improved) then
+c           Improved microphysics scheme
+c           ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+             Ctot = zq(ig,l,nq) + zq(ig,l,nq-1)
+             ph2o = zq(ig,l,nq) * 44. / 18. * pplay(ig,l)
+             satu = zq(ig,l,nq) / zqsat(ig,l)
+
+             call growthrate(ptimestep,zt(ig,l),pplay(ig,l),
+     &        ph2o,ph2o/satu,seq,rice(ig,l),gr)
+             Cste = ptimestep * 4. * pi * rice(ig,l)
+     *              * rho_ice * dustcores(ig,l)
+             up   = zq(ig,l,nq) + Cste * gr * seq
+             dwn  =    1.       + Cste * gr / zqsat(ig,l)
+             newvap = min(up/dwn,Ctot)
+
+             gr  = gr * ( newvap/zqsat(ig,l) - seq )
+             dzq = min( max( Cste * gr,-zq(ig,l,nq-1) ) 
+     *             , zq(ig,l,nq) )
+
+c            Nucleation (sat ratio must be larger than a critical value)
+c            ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+             if (satu.gt.1.) then
+               if (satu.le.1.4.and.zq(ig,l,nq-1).lt.1.e-8) 
+     *            dzq = 0.
+             endif
+
+            Else
+c           Old version
+c           ~~~~~~~~~~~
+             if (zq(ig,l,nq).ge.zqsat(ig,l))then  !  Condensation
+               dzq=zq(ig,l,nq)-zqsat(ig,l)                
+             elseif(zq(ig,l,nq).lt.zqsat(ig,l))then  ! Sublimation
+               dzq=-min(zqsat(ig,l)-zq(ig,l,nq),zq(ig,l,nq-1))
+             endif
+
+            Endif
+
+c           Water Mass change
+c           ~~~~~~~~~~~~~~~~~
+            zq(ig,l,nq-1)=zq(ig,l,nq-1)+dzq
+            zq(ig,l,nq)=zq(ig,l,nq)-dzq
+
+            rice(ig,l)=max( CBRT ( (zq(ig,l,nq-1)/rho_ice
+     &       +dustcores(ig,l)*(4./3.)*pi*rdust(ig,l)**3.)
+     &       /(dustcores(ig,l)*4./3.*pi) ), rdust(ig,l)) 
+
+            if(activice.and.pclc(ig).gt.0)
+     &        rice(ig,l)=rice(ig,l)/CBRT(pclc(ig))
+              
+            enddo
+          enddo
+
+        else   ! if not iceparty
+
+c         Saturation couche nlay a 2 :
+c         ~~~~~~~~~~~~~~~~~~~~~~~~~~
+          do l=nlay,2, -1
+             do ig=1,ngrid
+             if (zq(ig,l,nq).gt.zqsat(ig,l))then 
+               zq(ig,l-1,nq) =  zq(ig,l-1,nq)+(zq(ig,l,nq)-zqsat(ig,l))
+     &          *(pplev(ig,l)-pplev(ig,l+1))/(pplev(ig,l-1)-pplev(ig,l))
+               zq(ig,l,nq)=zqsat(ig,l)
+             endif
+             enddo
+          enddo
+
+c       Saturation couche l=1 si pas iceparty 
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+          do ig=1,ngridmx
+              if (zq(ig,1,nq).gt.zqsat(ig,1))then
+                 pdqscloud(ig,nq)= (zq(ig,1,nq)-zqsat(ig,1))
+     &         *(pplev(ig,1)-pplev(ig,2))/(g*ptimestep)
+                 zq(ig,1,nq)=zqsat(ig,1)
+              endif
+          end do
+
+        endif   ! (iceparty)
+
+c       Tendance finale
+c       ~~~~~~~~~~~~~~~
+        do l=1, nlay
+          do ig=1,ngridmx
+            pdqcloud(ig,l,nq) = (zq(ig,l,nq) - zq0(ig,l,nq))/ptimestep
+            if(iceparty) then
+              pdqcloud(ig,l,nq-1) =
+     &        (zq(ig,l,nq-1) - zq0(ig,l,nq-1))/ptimestep
+            endif
+            lw=(2834.3-0.28*(zt(ig,l)-To)-0.004*(zt(ig,l)-To)**2)*1.e+3
+            pdtcloud(ig,l)=-pdqcloud(ig,l,nq)*lw/cpp
+          end do 
+        end do
+
+c       A correction if a lot of subliming CO2 fills the 1st layer FF04/2005
+c       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c       Then that should not affect the ice particle radius
+        do ig=1,ngridmx
+          if(pdpsrf(ig)*ptimestep.gt.0.9*(pplev(ig,1)-pplev(ig,2)))then
+            if(pdpsrf(ig)*ptimestep.gt.0.9*(pplev(ig,1)-pplev(ig,3)))
+     &      rice(ig,2)=rice(ig,3) 
+            rice(ig,1)=rice(ig,2)
+          end if
+        end do
+        
+c**************************************************
+c       Output  
+c**************************************************
+         do ig=1,ngridmx
+          do l=1 ,nlay
+c           masse de vapeur d'eau dans la couche l
+            mtot(ig)=mtot(ig)+pq(ig,l,nq)*masse(ig,l)
+            if(iceparty) then
+c             masse de glace d'eau dans la couche l
+              icetot(ig)=icetot(ig)+masse(ig,l)*pq(ig,l,nq-1)
+c             rayon moyen des cristaux dans la colonne ig
+              rave(ig)=rave(ig)+masse(ig,l)*pq(ig,l,nq-1)*rice(ig,l)
+              cloudmass(ig,l)=masse(ig,l)*pq(ig,l,nq-1)
+            endif
+          enddo
+          if(iceparty) then
+            rave(ig)=rave(ig)/max(icetot(ig),1.e-30)
+            if (icetot(ig)*1000.lt.0.01) rave(ig)=0.
+          endif
+         enddo   ! (ngridmx)
+
+c         Computing abs optical depth at 825 cm-1 in each layer
+c         to simulate NEW TES retrieval
+          do ig=1,ngridmx
+            tau825(ig)=0.
+            do l=1 ,nlay
+               Qabs=min(max(0.4e6*rice(ig,l)-0.05 ,0.),1.2)
+               op825(ig,l)= 0.75*Qabs*pq(ig,l,nq-1)*masse(ig,l)
+     &                       /  (rho_ice*rice(ig,l))
+               tau825(ig)=tau825(ig)+ op825(ig,l)
+            end do
+          end do
+
+c ******************************************    
+c      Output in diagfi
+c ******************************************    
+
+      if (ngrid.gt.1) then
+
+          CALL WRITEDIAGFI(ngridmx,'mtot',
+     &  'total mass of water vapor','kg/m2',2,mtot)
+
+         if (callstats) then
+            call wstats(ngrid,"mtot",
+     .   "total mass of water vapor","kg/m2",2,mtot)
+         endif
+
+c        if(.not.iceparty)
+c     &  call WRITEDIAGFI(ngridmx,'taucond',
+c     &  'taux cond H2O ice','kg/kg/s',3,taucond)
+c
+         if(iceparty) then
+            CALL WRITEDIAGFI(ngridmx,'icetot',
+     &    'total mass of water ice','kg/m2',2,icetot)
+           if (callstats) then
+              call wstats(ngrid,"icetot",
+     .        "total mass of water ice","kg/m2",2,icetot)
+           endif
+c          CALL WRITEDIAGFI(ngridmx,'cloudmass',
+c     &    'mass of water ice/layer','kg/m2',3,cloudmass)
+c          CALL WRITEDIAGFI(ngridmx,'rice','ice radius',
+c     &    'meter',3,rice)
+           CALL WRITEDIAGFI(ngridmx,'rave','Mean ice radius',
+     &    'meter',2,rave)
+           CALL WRITEDIAGFI(ngridmx,'tauice','tau abs 825 cm-1',
+     &    '',2,tau825)
+         endif
+
+      else
+
+c          CALL WRITEG1D(ngridmx,1,mtot,'gas','kg/m2')
+c          CALL WRITEG1D(ngridmx,1,icetot,'ice','kg/m2')
+c          call WRITEG1D(ngridmx,nlay,rice,'rice','um')
+c          call WRITEG1D(ngridmx,nlay,dustcores,'pouss','#/layer')
+
+      endif
+ 99   continue
+
+      RETURN
+      END
+ 
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watersat.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watersat.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/watersat.F	(revision 57)
@@ -0,0 +1,47 @@
+      SUBROUTINE watersat(nsize,t,p,qsat)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c  Water mass mixing ratio at saturation (kg/kg) for a given pressure (Pa)
+c   and Temperature (K) array
+c
+c=======================================================================
+
+c   declarations:
+c   -------------
+c   arguments:
+c   ----------
+
+c   INPUT
+      integer nsize 
+      real t(nsize) , p(nsize)
+c   OUTPUT
+      real qsat(nsize)
+
+c   local:
+c   ------
+      INTEGER i
+      REAL r2,r3,r4 , To, es
+      SAVE r2,r3,r4
+      DATA r2,r3,r4/611.14,21.875,7.66/
+      SAVE To
+      DATA To/273.16/
+          
+      do i=1,nsize
+c        pression de vapeur saturante :
+c         es =r2*exp(r3*(t(i)-To)/(t(i)-r4))
+c         qsat(i)=es/p(i)*0.41  !rapport de melange
+        es=2.07023-0.00320991*t(i)-2484.896/t(i)+3.56654*alog10(t(i))
+        es=10.**es 
+        qsat(i)=(es*100.)/p(i)*0.41 
+
+c        qss = specific humidity
+c        qss=622*10**(2.07023-0.0032991*Tsurf(ig)-2484.896/Tsurf(ig)
+c    $                  +3.56654*log10(Tsurf(ig)))
+
+      enddo
+
+      RETURN
+      END
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writediagfi.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writediagfi.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writediagfi.F	(revision 57)
@@ -0,0 +1,353 @@
+      subroutine writediagfi(ngrid,nom,titre,unite,dim,px)
+
+!  Ecriture de variables diagnostiques au choix dans la physique 
+!  dans un fichier NetCDF nomme  'diagfi'. Ces variables peuvent etre
+!  3d (ex : temperature), 2d (ex : temperature de surface), ou
+!  0d (pour un scalaire qui ne depend que du temps : ex : la longitude
+!  solaire)
+!  Dans la version 2000, la periode d'ecriture est celle de 
+!  "ecritphy " regle dans le fichier de controle de run :  run.def
+!
+!    writediagfi peut etre appele de n'importe quelle subroutine
+!    de la physique, plusieurs fois. L'initialisation et la creation du
+!    fichier se fait au tout premier appel.
+!
+! WARNING : les variables dynamique (u,v,t,q,ps)
+!  sauvees par writediagfi avec une
+! date donnee sont legerement differentes que dans le fichier histoire car 
+! on ne leur a pas encore ajoute de la dissipation et de la physique !!!
+! IL est  RECOMMANDE d'ajouter les tendance physique a ces variables
+! avant l'ecriture dans diagfi (cf. physiq.F)
+!  
+!
+!  parametres (input) :
+!  ----------
+!      ngrid : nombres de point ou est calcule la physique
+!                (ngrid = 2+(jjm-1)*iim - 1/jjm)
+!                 (= nlon ou klon dans la physique terrestre)
+!      
+!      unit : unite logique du fichier de sortie (toujours la meme)
+!      nom  : nom de la variable a sortir (chaine de caracteres)
+!      titre: titre de la variable (chaine de caracteres)
+!      unite : unite de la variable (chaine de caracteres)
+!      px : variable a sortir (real 0, 2, ou 3d)
+!      dim : dimension de px : 0, 2, ou 3 dimensions
+!
+!=================================================================
+ 
+      implicit none
+
+! Commons
+#include "dimensions.h"
+#include "dimphys.h"
+#include "paramet.h"
+#include "control.h"
+#include "comvert.h"
+#include "comgeom.h"
+#include "description.h"
+#include "netcdf.inc"
+#include "temps.h"
+#include "surfdat.h"
+
+! Arguments on input:
+      integer ngrid
+      character (len=*) :: nom,titre,unite
+      integer dim
+      real px(ngrid,llm)
+
+! Local variables:
+
+      real dx3(iip1,jjp1,llm) ! to store a 3D data set
+      real dx2(iip1,jjp1)     ! to store a 2D (surface) data set
+      real dx0
+
+      real date
+
+      REAL phis(ip1jmp1)
+
+      integer irythme
+      integer ierr
+      integer iq
+      integer i,j,l,zmax , ig0
+
+      integer zitau
+      character firstnom*10
+      SAVE firstnom
+      SAVE zitau
+      SAVE date
+      data firstnom /'1234567890'/
+      data zitau /0/
+
+! Ajouts
+      integer, save :: ntime=0
+      integer :: idim,varid
+      integer :: nid
+      character (len =50):: fichnom
+      integer, dimension(4) :: id
+      integer, dimension(4) :: edges,corner
+      
+
+!***************************************************************
+!Sortie des variables au rythme voulu
+
+      irythme = int(ecritphy) ! sortie au rythme de ecritphy
+!     irythme = iconser  ! sortie au rythme des variables de controle
+!     irythme = iphysiq  ! sortie a tous les pas physique
+!     irythme = iecri*day_step ! sortie au rythme des fichiers histoires
+!     irythme = periodav*day_step ! sortie au rythme des fichiers histmoy
+
+!***************************************************************
+
+! The following test is here to enforce that writediagfi is not used with the
+! 1D version of the GCM
+      if (ngrid.eq.1) return
+      
+c     nom=trim((nom))
+c     unite=trim((unite))
+c     titre=trim((titre))
+
+! Initialisation of 'firstnom' and create/open the "diagfi.nc" NetCDF file
+! ------------------------------------------------------------------------
+! (Au tout premier appel de la subroutine durant le run.)
+
+      fichnom="diagfi.nc"
+
+      if (firstnom.eq.'1234567890') then ! .true. for the very first call
+      !  to this subroutine; now set 'firstnom'
+         firstnom = nom
+
+         call gr_fi_dyn(1,ngrid,iip1,jjp1,phisfi,phis)
+         ! Create the NetCDF file
+         ierr = NF_CREATE(fichnom, NF_CLOBBER, nid)
+         ! Define the 'Time' dimension
+         ierr = nf_def_dim(nid,"Time",NF_UNLIMITED,idim)
+         ! Define the 'Time' variable
+#ifdef NC_DOUBLE
+         ierr = NF_DEF_VAR (nid, "Time", NF_DOUBLE, 1, idim,varid)
+#else
+         ierr = NF_DEF_VAR (nid, "Time", NF_FLOAT, 1, idim,varid)
+#endif
+         ! Add a long_name attribute
+         ierr = NF_PUT_ATT_TEXT (nid, varid, "long_name",
+     .          4,"Time")
+         ! Add a units attribute
+         ierr = NF_PUT_ATT_TEXT(nid, varid,'units',29,
+     .          "days since 0000-00-0 00:00:00")
+         ! Switch out of NetCDF Define mode
+         ierr = NF_ENDDEF(nid)
+
+         ! write "header" of file (longitudes, latitudes, geopotential, ...)
+         call iniwrite(nid,day_ini,phis)
+         
+         zitau = -1 ! initialize zitau
+      else
+         ! Open the NetCDF file
+         ierr = NF_OPEN(fichnom,NF_WRITE,nid)
+      endif ! if (firstnom.eq.'1234567890')
+
+! Increment time index 'zitau' if it is the "fist call" (at given time level)
+! to writediagfi
+!------------------------------------------------------------------------
+      if (nom.eq.firstnom) then
+          zitau = zitau + iphysiq
+      end if
+
+!--------------------------------------------------------
+! Write the variables to output file if it's time to do so
+!--------------------------------------------------------
+
+      if ( MOD(zitau+1,irythme) .eq.0.) then
+
+! Compute/write/extend 'Time' coordinate (date given in days)
+! (done every "first call" (at given time level) to writediagfi)
+! Note: date is incremented as 1 step ahead of physics time
+!       (like the 'histoire' outputs)
+!--------------------------------------------------------
+
+        if (nom.eq.firstnom) then
+        ! We have identified a "first call" (at given date)
+           ntime=ntime+1 ! increment # of stored time steps
+           ! compute corresponding date (in days and fractions thereof)
+           date= float (zitau +1)/float (day_step)
+           ! Get NetCDF ID of 'Time' variable
+           ierr= NF_INQ_VARID(nid,"Time",varid)
+           ! Write (append) the new date to the 'Time' array
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,ntime,1,date)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,ntime,1,date)
+#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi_nc"
+              write(*,*) "***** with time"
+              write(*,*) 'ierr=', ierr   
+c             call abort
+           endif
+
+           write(6,*)'WRITEDIAGFI: date= ', date
+        end if ! of if (nom.eq.firstnom)
+
+!Case of a 3D variable
+!---------------------
+        if (dim.eq.3) then
+
+!         Passage variable physique -->  variable dynamique
+!         recast (copy) variable from physics grid to dynamics grid
+           DO l=1,llm
+             DO i=1,iip1
+                dx3(i,1,l)=px(1,l)
+                dx3(i,jjp1,l)=px(ngrid,l)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx3(i,j,l)=px(ig0+i,l)
+                ENDDO
+                dx3(iip1,j,l)=dx3(1,j,l)
+             ENDDO
+           ENDDO
+
+!         Ecriture du champs
+
+!         write (*,*) 'In  writediagfi, on sauve:  ' , nom
+!         write (*,*) 'In  writediagfi. Estimated date = ' ,date
+! name of the variable
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+              ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
+
+           endif 
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=1
+           corner(4)=ntime
+
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=llm
+           edges(4)=1
+#ifdef NC_DOUBLE
+           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,dx3)
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx3)
+#endif
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR problem in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr
+c             call abort
+           endif 
+
+!Case of a 2D variable
+!---------------------
+
+        else if (dim.eq.2) then
+
+!         Passage variable physique -->  physique dynamique
+!         recast (copy) variable from physics grid to dynamics grid
+
+             DO i=1,iip1
+                dx2(i,1)=px(1,1)
+                dx2(i,jjp1)=px(ngrid,1)
+             ENDDO
+             DO j=2,jjm
+                ig0= 1+(j-2)*iim
+                DO i=1,iim
+                   dx2(i,j)=px(ig0+i,1)
+                ENDDO
+                dx2(iip1,j)=dx2(1,j)
+             ENDDO
+
+!         write (*,*) 'In  writediagfi, on sauve:  ' , nom
+!         write (*,*) 'In  writediagfi. Estimated date = ' ,date
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+              ierr= NF_INQ_DIMID(nid,"Time",id(3))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+
+              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
+
+           endif
+
+           corner(1)=1
+           corner(2)=1
+           corner(3)=ntime
+           edges(1)=iip1
+           edges(2)=jjp1
+           edges(3)=1
+
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,dx2) 
+#else         
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx2)
+#endif     
+
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr
+c             call abort
+           endif 
+
+!Case of a 0D variable (ie: a time-dependent scalar)
+!---------------------------------------------------
+
+        else if (dim.eq.0) then
+           dx0 = px (1,1)
+
+           ierr= NF_INQ_VARID(nid,nom,varid)
+           if (ierr /= NF_NOERR) then
+! corresponding dimensions
+              ierr= NF_INQ_DIMID(nid,"Time",id(1))
+
+! Create the variable if it doesn't exist yet
+
+              write (*,*) "=========================="
+              write (*,*) "DIAGFI: creating variable ",nom
+
+              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
+
+           endif
+
+           corner(1)=ntime
+           edges(1)=1
+
+#ifdef NC_DOUBLE
+           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,dx0)  
+#else
+           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,dx0)
+#endif
+           if (ierr.ne.NF_NOERR) then
+              write(*,*) "***** PUT_VAR matter in writediagfi"
+              write(*,*) "***** with ",nom
+              write(*,*) 'ierr=', ierr
+c             call abort
+           endif 
+
+        endif ! of if (dim.eq.3) elseif(dim.eq.2)...
+
+      endif ! of if ( MOD(zitau+1,irythme) .eq.0.)
+
+      ierr= NF_CLOSE(nid)
+
+      end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writeg1d.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writeg1d.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/writeg1d.F	(revision 57)
@@ -0,0 +1,204 @@
+      SUBROUTINE writeg1d(ngrid,nx,x,nom,titre)
+      IMPLICIT NONE
+c.......................................................................
+c
+c  ecriture de x pour GRADS-1D
+c
+c  in :
+c         * ngrid      ---> pour controler que l'on est bien en 1D
+c         * nx         ---> taille du vecteur a stocker
+c                             "1" pour une variable de surface
+c                             "nlayer" pour une variable de centre de couche
+c                             "nlayer+1" pour une variable d'interface
+c         * x          ---> variable a stocker
+c         * nom        ---> nom "pour grads"
+c         * titre      ---> titre "pour grads"
+c
+c.......................................................................
+c
+#include "comg1d.h"
+
+c
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER ngrid,nx,i
+      REAL*4 xr4(1000)
+      REAL x(nx)
+      CHARACTER*(*) nom,titre
+c
+c  declaration des arguments 
+c....................................................................... 
+c  declaration des variables locales
+c
+      INTEGER ilayer,ivar
+      LOGICAL test 
+c
+c  declaration des variables locales
+c.......................................................................
+c  controle 1D
+c
+c     print*,'ngrid=',ngrid
+      IF (ngrid.NE.1) return
+c
+c  controle 1D
+c.......................................................................
+c  copy => force en reel 4 pour l'ecriture dans grads1d.dat
+
+      do i=1,nx
+        xr4(i) = x(i)
+      enddo
+
+c  copy => force en reel 4 pour l'ecriture dans grads1d.dat
+c.......................................................................
+c  ouverture du fichier au premier appel
+c
+      IF (g1d_premier) THEN
+        OPEN (g1d_unitfich,FILE=g1d_nomfich
+     &       ,FORM='unformatted',ACCESS='direct',RECL=4)
+        g1d_irec=0
+        g1d_nvar=0
+        g1d_premier=.false.
+      ENDIF
+c
+c  ouverture du fichier au premier appel
+c.......................................................................
+c  pour l'ecriture du fichier ctl
+c
+      test=.true.
+      DO ivar=1,g1d_nvar
+        IF (nom.EQ.g1d_nomvar(ivar)) test=.false.
+        IF (nx .GT. 1000) then
+          print*,'ERROR:  nx > 1000 dans writeg1d.F' 
+          print*,'Changer la dimension de xr4'
+          call exit(1)
+        ENDIF
+      ENDDO
+      IF (test) THEN
+        g1d_nvar=g1d_nvar+1
+        g1d_nomvar(g1d_nvar)=nom
+        g1d_titrevar(g1d_nvar)=titre
+        IF (nx.EQ.1) THEN
+           g1d_dimvar(g1d_nvar)=0
+        ELSEIF (nx.EQ.g1d_nlayer) THEN
+           g1d_dimvar(g1d_nvar)=g1d_nlayer
+        ELSEIF (nx.EQ.g1d_nlayer+1) THEN
+           g1d_dimvar(g1d_nvar)=g1d_nlayer+1
+        ELSE
+           PRINT *,'._. probleme de dimension dans GRADS-1D ._.'
+           print*,'NX = ',nx
+           print*,'g1d_nlayer = ',g1d_nlayer
+        ENDIF
+      ENDIF
+c
+c  pour l'ecriture du fichier ctl
+c.......................................................................
+c  ecriture
+c
+      IF (nx.EQ.1) THEN
+        g1d_irec=g1d_irec+1
+        WRITE(g1d_unitfich,REC=g1d_irec) xr4(1)
+      ELSE
+        DO ilayer=1,g1d_nlayer
+          g1d_irec=g1d_irec+1
+          WRITE(g1d_unitfich,REC=g1d_irec) xr4(ilayer)
+        ENDDO
+      ENDIF
+c
+c  ecriture
+c.......................................................................
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+      RETURN
+      END
+
+
+
+
+
+c *********************************************************************
+c *********************************************************************
+
+      SUBROUTINE endg1d(ngrid,nlayer,zlayer,ndt)
+      IMPLICIT NONE
+c.......................................................................
+c
+c  ecriture du fichier de controle pour GRADS-1D
+c
+c  in :
+c         * ngrid      ---> pour controler que l'on est bien en 1D
+c         * nlayer     ---> nombre de couches
+c         * zlayer     ---> altitude au centre de chaque couche (km)
+c         * ndt        ---> nombre de pas de temps
+c
+c.......................................................................
+c
+#include "comg1d.h"
+#include "comcstfi.h"
+c
+c.......................................................................
+c  declaration des arguments 
+c
+      INTEGER ngrid,nlayer
+      REAL zlayer(nlayer)
+      INTEGER ndt
+c
+c  declaration des arguments 
+c....................................................................... 
+c  declaration des variables locales
+c
+      INTEGER ivar,ilayer
+c
+c  declaration des variables locales
+c.......................................................................
+c  contole 1D
+c
+      IF (ngrid.NE.1) GOTO 10001
+c
+c  contole 1D
+c.......................................................................
+c
+      IF (nlayer.ne.g1d_nlayer) 
+     &PRINT *,'._. probleme de dimension dans GRADS-1D (endg1d.F) '
+c
+c.......................................................................
+c
+      CLOSE (g1d_unitfich)
+c
+c.......................................................................
+c
+      OPEN (g1d_unitctl,FILE=g1d_nomctl,FORM='formatted',RECL=4*100)
+      WRITE (g1d_unitctl,'(a4,2x,a1,a20)') 'DSET','^',g1d_nomfich
+      WRITE (g1d_unitctl,'(a5,2x,a20)') 'UNDEF ','1.E+30'
+      WRITE (g1d_unitctl,'(a11)') 'FORMAT YREV'
+      WRITE (g1d_unitctl,'(a5,2x,a30)') 'TITLE ','champs 1D'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'XDEF ',1,' LINEAR 0 1'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'YDEF ',1,' LINEAR 0 1'
+      WRITE (g1d_unitctl,'(a5,i4,a20)') 'ZDEF ',g1d_nlayer,' LEVELS'
+      WRITE (g1d_unitctl,'(5(1x,f13.5))')
+     &      (zlayer(ilayer),ilayer=1,g1d_nlayer)
+
+c     Writing true timestep in g1d.ctl (in planet "minutes"= sol/(60*24)
+      ivar =min( max(int(1440.*dtphys/daysec +0.5),1) , 99)   
+      WRITE (g1d_unitctl,'(a4,2x,i10,a19,i2,a2)')
+     &      'TDEF ',ndt,' LINEAR 01JAN2000 ', ivar,'MN '
+
+      WRITE (g1d_unitctl,'(a5,i5)') 'VARS ',g1d_nvar
+      DO ivar=1,g1d_nvar
+      WRITE (g1d_unitctl,'(a9,3x,i4,i3,1x,a39)') 
+     &       g1d_nomvar(ivar),g1d_dimvar(ivar),99,g1d_titrevar(ivar)
+      ENDDO
+      WRITE (g1d_unitctl,'(a7)') 'ENDVARS'
+      CLOSE (g1d_unitctl)
+c
+c.......................................................................
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/wstats.F90
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/wstats.F90	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/wstats.F90	(revision 57)
@@ -0,0 +1,279 @@
+subroutine wstats(ngrid,nom,titre,unite,dim,px)
+
+implicit none
+
+#include "dimensions.h"
+#include "dimphys.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+integer,intent(in) :: ngrid
+character (len=*) :: nom,titre,unite
+integer,intent(in) :: dim
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+real, dimension(ngrid,llm) :: px
+real, dimension(iip1,jjp1,llm) :: mean3d,sd3d,dx3
+real, dimension(iip1,jjp1) :: mean2d,sd2d,dx2
+character (len=50) :: namebis
+character (len=50), save :: firstvar
+integer :: ierr,varid,nbdim,nid
+integer :: meanid,sdid
+integer, dimension(4)  :: id,start,size
+logical, save :: firstcall=.TRUE.
+integer :: l,i,j,ig0
+integer,save :: index
+
+integer, save :: step=0
+
+
+if (firstcall) then
+   firstcall=.false.
+   firstvar=trim((nom))
+   call inistats(ierr)
+endif
+
+if (firstvar==nom) then ! If we're back to the first variable
+      step = step + 1
+endif
+
+if (mod(step,istats).ne.0) then
+   RETURN
+endif
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+namebis=trim(nom)
+ierr= NF_INQ_VARID(nid,namebis,meanid)
+
+if (ierr.ne.NF_NOERR) then
+
+   if (firstvar==nom) then 
+      index=1
+      count=0
+   endif
+
+
+!declaration de la variable
+
+! choix du nom des coordonnees
+   ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+   ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+   if (dim.eq.3) then
+      ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+      ierr= NF_INQ_DIMID(nid,"Time",id(4))
+      nbdim=4
+   else if (dim==2) then
+      ierr= NF_INQ_DIMID(nid,"Time",id(3))
+      nbdim=3
+   endif
+
+   write (*,*) "====================="
+   write (*,*) "STATS: creation de ",nom
+   namebis=trim(nom)
+   call def_var(nid,namebis,titre,unite,nbdim,id,meanid,ierr)
+   call inivar(nid,meanid,ngrid,dim,index,px,ierr)
+   namebis=trim(nom)//"_sd"
+   call def_var(nid,namebis,trim(titre)//" total standard deviation over the season",unite,nbdim,id,sdid,ierr)
+   call inivar(nid,sdid,ngrid,dim,index,px,ierr)
+
+   ierr= NF_CLOSE(nid)
+   return
+
+else
+   namebis=trim(nom)//"_sd"
+   ierr= NF_INQ_VARID(nid,namebis,sdid)
+
+endif
+
+if (firstvar==nom) then 
+   count(index)=count(int(index))+1
+   index=index+1
+   if (index>istime) then
+      index=1
+   endif
+endif
+
+if (count(index)==0) then
+   if (dim.eq.3) then
+      start=(/1,1,1,index/)
+      size=(/iip1,jjp1,llm,1/)
+      mean3d=0
+      sd3d=0
+   else if (dim.eq.2) then
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+      mean2d=0
+      sd2d=0
+   endif
+else
+   if (dim.eq.3) then
+      start=(/1,1,1,index/)
+      size=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean3d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd3d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean3d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd3d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+   else if (dim.eq.2) then
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean2d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd2d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean2d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd2d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+   endif
+endif
+
+if (dim.eq.3) then
+
+!  Passage variable physique -->  variable dynamique
+
+   DO l=1,llm
+      DO i=1,iip1
+         dx3(i,1,l)=px(1,l)
+         dx3(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            dx3(i,j,l)=px(ig0+i,l)
+         ENDDO
+         dx3(iip1,j,l)=dx3(1,j,l)
+      ENDDO
+   ENDDO
+
+   mean3d= mean3d+dx3
+   sd3d= sd3d+dx3**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean3d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd3d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean3d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd3d)
+#endif
+
+else if (dim.eq.2) then
+
+!    Passage variable physique -->  physique dynamique
+
+  DO i=1,iip1
+     dx2(i,1)=px(1,1)
+     dx2(i,jjp1)=px(ngrid,1)
+  ENDDO
+  DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        dx2(i,j)=px(ig0+i,1)
+     ENDDO
+     dx2(iip1,j)=dx2(1,j)
+  ENDDO
+
+   mean2d= mean2d+dx2
+   sd2d= sd2d+dx2**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean2d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd2d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean2d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd2d)
+#endif
+
+endif
+
+ierr= NF_CLOSE(nid)
+
+end
+
+!======================================================
+subroutine inivar(nid,varid,ngrid,dim,index,px,ierr)
+
+implicit none
+
+include "dimensions.h"
+include "dimphys.h"
+include "netcdf.inc"
+
+integer, intent(in) :: nid,varid,dim,index,ngrid
+real, dimension(ngrid,llm), intent(in) :: px
+integer, intent(out) :: ierr
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+
+integer :: l,i,j,ig0
+integer, dimension(4) :: start,size
+real, dimension(iip1,jjp1,llm) :: dx3
+real, dimension(iip1,jjp1) :: dx2
+
+if (dim.eq.3) then
+
+   start=(/1,1,1,index/)
+   size=(/iip1,jjp1,llm,1/)
+
+!  Passage variable physique -->  variable dynamique
+
+   DO l=1,llm
+      DO i=1,iip1
+         dx3(i,1,l)=px(1,l)
+         dx3(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            dx3(i,j,l)=px(ig0+i,l)
+         ENDDO
+         dx3(iip1,j,l)=dx3(1,j,l)
+      ENDDO
+   ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx3)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx3)
+#endif
+
+else if (dim.eq.2) then
+
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+
+!    Passage variable physique -->  physique dynamique
+
+  DO i=1,iip1
+     dx2(i,1)=px(1,1)
+     dx2(i,jjp1)=px(ngrid,1)
+  ENDDO
+  DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        dx2(i,j)=px(ig0+i,1)
+     ENDDO
+     dx2(iip1,j)=dx2(1,j)
+  ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx2)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx2)
+#endif
+
+endif
+
+end
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yoegwd.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yoegwd.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yoegwd.h	(revision 57)
@@ -0,0 +1,16 @@
+C     -----------------------------------------------------------------
+C*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+C     -----------------------------------------------------------------
+C
+      real GFRCRIT,GRCRIT,GVCRIT,GKDRAG,GKDRAGL,GHMAX
+     *             , GRAHILO,GSIGCR,GSSEC, GTSEC,  GVSEC
+     *             ,GKWAKE
+
+      integer NKTOPG
+
+      COMMON/YOEGWD/ GFRCRIT,GRCRIT,GVCRIT,GKDRAG,GKDRAGL,GHMAX
+     *             , GRAHILO,GSIGCR,NKTOPG,GSSEC, GTSEC,  GVSEC
+     *             ,GKWAKE
+C
+
+
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomaer.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomaer.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomaer.h	(revision 57)
@@ -0,0 +1,29 @@
+C*    Radiative characteristics of the aerosols
+C
+C   Shortwave
+c   ~~~~~~~~~
+c
+c tauvis: dust optical depth at reference wavelength  ("longrefvis" set
+c in dimradmars.h : typically longrefvis = 0.67E-6 m, as measured by Viking )
+
+c For the "naerkind" kind of aerosol radiative properties : 
+C QVISsQREF  :  Qext / Qext("longrefvis")   <--- For both solar bands
+C omegavis   :  sinle scattering albedo     <--- For both solar bands
+C gvis       :  assymetry factor            <--- For both solar bands
+c
+C   Longwave
+c   ~~~~~~~~
+c
+c For the "naerkind" kind of aerosol radiative properties : 
+c QIRsQREF :  Qext / Qext("longrefvis")     <--- For the nir bandes IR
+c omegaIR  :  mean single scattering albedo <--- For the nir bandes IR
+c gIR      :  mean assymetry factor         <--- For the nir bandes IR
+c
+      real tauvis
+      real QVISsQREF(nsun,naerkind)
+      real omegavis(nsun,naerkind),gvis(nsun,naerkind)
+      real QIRsQREF(nir,naerkind)
+      real omegaIR(nir,naerkind),gIR(nir,naerkind)
+
+      COMMON/YOMAER/tauvis,QVISsQREF,omegavis,gvis,
+     &              QIRsQREF,omegaIR,gIR
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomlw.h
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomlw.h	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/yomlw.h	(revision 57)
@@ -0,0 +1,21 @@
+C*    Coefficients for the longwave radiation subroutines
+c-----------------------------------------------------------------------
+
+      COMMON/yomlw/at(2,2),bt(2,2)
+     S ,tref,xp(6,nir),tstand
+     S ,ga(npademx,nabsmx),gb(npademx,nabsmx)
+     S ,cst_voigt(2,nabsmx), gcp , nlaylte
+
+      REAL at,bt, tref,xp,tstand,ga,gb, cst_voigt
+      REAL gcp    ! = g/cpp
+
+c     Number of layers on which LTE calculations (in lw and sw) are performed 
+c     (Computed in nlthermeq) :
+      INTEGER nlaylte       
+
+
+      COMMON/ksicom/
+     S xi(ngridmx,nuco2,0:nflev+1,0:nflev+1)
+     S ,xi_ground(ngridmx,nuco2),xi_emis(ngridmx,nuco2,nflev-1)
+
+      real xi, xi_ground, xi_emis
Index: trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/zerophys.F
===================================================================
--- trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/zerophys.F	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/libf_gcm/phymars/zerophys.F	(revision 57)
@@ -0,0 +1,11 @@
+      SUBROUTINE zerophys(n,x)
+      IMPLICIT NONE
+      INTEGER n
+      REAL x(n)
+      INTEGER i
+
+      DO i=1,n
+         x(i)=0.
+      ENDDO
+      RETURN
+      END
Index: trunk/mesoscale/LMDZ.MARS/makegcm
===================================================================
--- trunk/mesoscale/LMDZ.MARS/makegcm	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/makegcm	(revision 57)
@@ -0,0 +1,791 @@
+#!/bin/csh
+# $Header: /users/lmdz/cvsroot/LMDZ.3.3/makegcm,v 1.21 2001/07/04 08:41:44 lmdz Exp $
+#set verbose echo
+########################################################################
+# options par defaut pour la commande make
+########################################################################
+set dim="64x48x32"
+set physique=mars
+set phys="PHYS=$physique"
+set include='-I$(LIBF)/grid -I$(LIBF)/bibio -I. -I$(LIBF)/aeronomars'
+set ntrac = 1
+set filtre=filtrez
+set grille=reg
+set dyntype="dyn"
+########################################################################
+# path a changer contenant les sources et les objets du modele
+########################################################################
+
+###### VERSION LMDZ.3.3
+# set LMDGCM=$HOME/LMDZ.3.3
+#
+
+setenv localdir "`pwd`"
+set MODIPSL=0
+echo $localdir | grep modipsl >& /dev/null
+if ( ! $status ) then
+  set MODIPSL=1
+  setenv LMDGCM $localdir
+  cd ../..
+  setenv LIBOGCM "`pwd`/lib"
+  cd $localdir
+  if ( `hostname` == rhodes ) then
+    set NCDFINC=`grep sxnec ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+    set NCDFLIB=`grep sxnec ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+  else
+    if ( `hostname` == nymphea0 ) then
+      set NCDFINC=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_INC|sed -e "s/^.* =//"`
+      set NCDFLIB=`grep fjvpp ../../util/AA_make.gdef| grep NCDF_LIB|sed -e 's/^.* =//'`
+    else
+      echo 'Probleme de definition des variables NCDFINC et NCDFLIB'
+    endif 
+  endif 
+else
+  if ( ! $?LMDGCM ) then
+    echo You must initialize the variable LMDGCM in your environnement
+    echo for instance: "setenv LMDGCM /usr/myself/supergcm" in .cshrc
+    exit
+  endif
+  if ( ! $?LIBOGCM ) then
+    set LIBOGCM=$LMDGCM/libo
+  endif
+  if ( ! $?NCDFLIB ) then
+    echo You must initialize the variable NCDFLIB in your environnement
+    echo for instance: "setenv NCDFLIB /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+  if ( ! $?NCDFINC ) then
+    echo You must initialize the variable NCDFINC in your environnement
+    echo for instance: "setenv NCDFINC /usr/myself/netcdf" in .cshrc
+    exit
+  endif
+endif
+set model=$LMDGCM
+set libo=$LIBOGCM
+
+########################################################################
+#  Les differentes platformes reconnues
+########################################################################
+
+set HP=0
+set IBM=0
+set SUN=0
+set VPP=0
+set CRAY=0
+set DEC=0
+set LINUX=0
+set NEC=0
+set XNEC=0
+if ( `uname` == HP-UX ) then
+   set machine=HP
+   set HP=1
+else if (`uname` == UNIX_System_V ) then
+   set machine=VPP
+   set VPP=1
+else if (`uname` == SunOS ) then
+   set machine=SUN
+   set SUN=1
+else if ( `uname` == AIX ) then
+   set machine=IBM
+   set IBM=1
+else if ( `uname` == OSF1 ) then
+   set machine=ALPHA
+   set DEC=1
+else if ( `uname` == Linux ) then
+   set machine=LINUX
+   set LINUX=1
+else if ( `hostname` == atlas || `hostname` == axis  || `hostname` == etoile ) then
+   set machine=CRAY
+   set CRAY=1
+else if ( `uname` == SUPER-UX ) then
+   set machine=NEC
+   set NEC=1
+else if ( `hostname` == rhodes) then
+   set machine=XNEC
+   set XNEC=1
+else
+   echo Vous travaillez sur une machine non prevue par le reglement
+   exit
+endif
+
+# create $libo directory if it doesn't exist
+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 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 optim90="-Wp'-P' -DCRAY "'-p$(LIBO) -eiv '
+   set oplink="-Wl'-DSTACK=128 -f indef' -L$NCDFLIB -lnetcdf "
+   set mod_loc_dir=" "
+   set mod_suffix=" "
+else if $SUN then
+   set optim90=" -fast"
+   set optimtru90=" -fast -free"
+   set opt_link="-L$NCDFLIB -lnetcdf"
+   set mod_loc_dir=$localdir
+   set mod_suffix=mod
+else if $HP then
+else if $IBM then
+else if $VPP then
+   set optim90="$optim -X9 -w"
+   if $COUPLE then
+     set opt_link="-Wg,-c $IOIPSLDIR/liboasis2.4_mpi2.a /usr/lang/mpi2/lib64/libmpi.a /usr/lang/mpi2/lib64/libmp.a /usr/local/lib/lib64/libnetcdf_cc.a -L$IOIPSLDIR -lioipsl"
+     set oplink="-Wl,-t,-P,-dy "
+   else
+     set opt_link="-Wg,-c /usr/local/lib/lib64/libnetcdf_cc.a -L$IOIPSLDIR -lioipsl"
+     set oplink="-Wl,-t,-dy "
+   endif
+   set mod_loc_dir=$IOIPSLDIR
+   set mod_suffix=mod
+else if $DEC then
+else if $LINUX then
+   set optim90=" -fast"
+   set optimtru90=" -fast -c -Mfree "
+#   set opt_link=" -Mfree -L/usr/local/pgi/linux86/lib -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$NCDFLIB -lnetcdf -Wl,-Bstatic "
+# Ehouarn: there is no /usr/local/pgi/linux86/lib, but it doesn't matter
+#          also changed -Wl,-Bstatic to -Bstatic
+   set opt_link=" -Mfree -lpgf90 -lpgftnrtl -lpghpf -lpghpf2 -L$NCDFLIB -lnetcdf -Bstatic "
+   set mod_loc_dir=""
+   set mod_suffix=mod
+else if $NEC then
+   set optim90=' -clear -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+   set optimtru90=' -clear -f4 -C hopt -float0 -ew -P static -Wf,"-pvctl fullmsg noassume "'
+###   set opt_link=" -C hopt -float0 -ew -P static -L$IOIPSLDIR -lioipsl  -L/u/rech/psl/rpsl003/IOIPSL -lnetcdf_i8r8_v "
+   set opt_link=" -C hopt -float0 -ew -P static -L/SX/usr/local/lib  -lnetcdf_i8r8 "
+   set mod_loc_dir="."
+   set mod_suffix="mod"
+else if $XNEC then
+   set optim90=' -clear -R5 -C vopt -float0 -ew -P static -Wf,"-pvctl loopcnt=40000 fullmsg noassume "'
+   set optimtru90=' -clear -R5 -f4 -C vopt -float0 -ew -P static -Wf,"-pvctl loopcnt=40000 fullmsg noassume "'
+   if $MODIPSL then
+     if $COUPLE then
+       set opt_link="-L$IOIPSLDIR -lsxioipsl -loasis2.4_mpi2 -float0 -ew -P static -I$NCDFINC $NCDFLIB "
+     else
+       set opt_link="-L$IOIPSLDIR -lsxioipsl -float0 -ew -P static -I$NCDFINC $NCDFLIB "
+     endif
+     set mod_loc_dir="./"
+   else
+####     set opt_link=" -C hopt -float0 -ew -P static -L$IOIPSLDIR -lsxioipsl -L /u/rech/psl/rpsl003/IOIPSL -lnetcdf_i8r8_v -I$NCDFINC -L/SX/usr/local/lib -lnetcdf_i8r8"
+     set opt_link=" -C hopt -float0 -ew -P static -I$NCDFINC -L/SX/usr/local/lib -lnetcdf_i8r8"
+     set mod_loc_dir="."
+   endif
+   set mod_suffix="mod"
+
+endif
+
+set nomlib=$machine
+
+# Impose distinct name for 64 bit Linux machines (to avoid mixing 32 and 64)
+if (`uname` == Linux && `uname -m` == "x86_64") then
+  set nomlib=${machine}64
+endif
+
+########################################################################
+# 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
+
+-olddyn    To compile GCM with "old dynamics"
+
+-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 optim90="$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 "
+
+     case -olddyn
+        set dyntype="olddyn" ; shift; goto top
+
+     case -filtre
+        set filtre=$2 ; shift ; shift ; goto top
+
+     case -link
+        set opt_link="$opt_link $2" ; shift ; shift ; goto top
+
+     case -debug
+        if $HP then
+           set optim90=" -g "
+        else if $SUN then
+           setenv PARALLEL 4
+           set optim90=" -g -C "
+           set optimtru90=" -g -C "
+        else if $CRAY then
+           set optim90="$optim90"" -G1 "
+        else if $LINUX then
+           set 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
+
+echo "apres les opts dim $dim"
+
+########################################################################
+# 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 ( $optim90 )
+   echo $i | sed -e 's/\"//g' -e "s/\'//g" -e 's/-//g' -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
+
+# dimension
+
+echo "dimension avant sed $dim"
+if ( $IBM ) then
+   set dim=`echo $dim | sed -en 's/[^0-9]/ /g'`
+   set dim_=`echo $dim | sed -en 's/[^0-9]/_/g'`
+else if ( $SUN || $XNEC ) then
+   set dim=`echo $dim | sed -e 's/[^0-9]/ /g'` 
+   set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'`
+else
+#   set dim=`echo $dim | sed -n -e 's/[^0-9]/ /gp'`
+#   set dim_=`echo $dim | sed -n -e 's/[^0-9]/_/gp'`
+     set dim=`echo $dim | sed -e 's/[^0-9]/ /g'`
+     set dim_=`echo $dim | sed -e 's/[^0-9]/_/g'`
+endif
+
+# build final name of libraries directory:
+if ( "$dyntype" == "olddyn" ) then
+  set nomlib=${nomlib}_${dim_}_t${ntrac}_${grille}_olddyn
+else
+  set nomlib=${nomlib}_${dim_}_t${ntrac}_${grille}
+endif
+
+# Append 'physique' type, if it is not mars, to nomlib
+if ( "$physique" != "mars" ) then
+  set nomlib=${nomlib}_${physique}
+endif
+
+## M-A-F nomlib trop long sur CRAY pour ar
+if ( $CRAY ) then
+    set nomlib=F90_${dim_}_t${ntrac}
+endif
+if ( $NEC || $XNEC ) then
+    set nomlib=F90_${dim_}_t${ntrac}
+endif
+
+echo "calcul de la dimension"
+set dimc=`echo $dim | wc -w`
+
+if ( "$dimc" == "2" ) then
+  set include="$include "'-I$(LIBF)/dyn2d '
+  set dimh=$dim
+else
+  if ( "$dyntype" == "olddyn" ) then
+    set include="$include "'-I$(LIBF)/olddyn3d '
+  else
+    set include="$include "'-I$(LIBF)/dyn3d '
+  endif
+  set dimh=`echo $dim | awk ' { print $1 "." $2 } '`
+endif
+echo "dimc is $dimc"
+
+########################################################################
+# path pour les #include
+########################################################################
+
+set include="$include -I$NCDFINC "
+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
+    #remove old dimensions.h file
+    \rm $libf/grid/dimensions.h
+  else
+    exit
+  endif
+endif
+
+# Build the appropriate 'dimensions.h' file
+cd dimension
+makdim $ntrac $dim
+# echo contents of dimensions.h to standard output
+cat $libf/grid/dimensions.h
+
+cd $LMDGCM
+# set path to objects directory
+set libo=$libo/$nomlib
+# create objects directory, if it doesn't exist
+if ( ! -d $libo )  then
+   mkdir $libo
+   cd $model
+endif
+
+########################################################################
+# Differentes dynamiques (3d, 2d, 1d)
+########################################################################
+
+set dimension=`echo $dim | wc -w`
+echo dimension $dimension dim $dim
+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.
+######################################################################
+
+# set filtre to 'oldfiltrez' if using -olddyn option
+if ( "$dyntype" == "olddyn" ) then
+  set filtre="oldfiltrez"
+endif
+
+if ( `expr $dimc \> 2` == 1 ) then
+   set filtre="FILTRE=$filtre"
+else
+   set filtre="FILTRE= L_FILTRE= "
+endif
+echo "MACRO FILTRE $filtre"
+
+echo "dimc $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
+find libf -name '*.[Fh]90' -print >> tmp90
+
+if (    `diff tmp77 liste_des_sources_f77 | wc -w` \
+     || `diff tmp90 liste_des_sources_f90 | wc -w` \
+     || ! -f makefile \
+     || ! -f liste_des_sources_f90 \
+     || ! -f liste_des_sources_f77 ) then
+        echo "les fichiers suivants ont ete crees ou detruits"
+        echo "ou les fichiers suivants sont passes ou ne sont plus en Fortran 90"
+        diff liste_des_sources_f77 tmp77
+        diff liste_des_sources_f90 tmp90
+        \cp tmp77 liste_des_sources_f77
+        \cp tmp90 liste_des_sources_f90
+        echo "On recree le makefile"
+        if ("$dyntype" == "olddyn") then
+          ./create_make_gcm olddyn3d grid bibio aeronomars phy$physique >! tmp
+        else
+          ./create_make_gcm dyn3d grid bibio aeronomars phy$physique >! tmp
+        endif
+        \mv tmp makefile
+        echo "Nouveau makefile cree."
+endif
+
+########################################################################
+#  Execution de la comande make
+########################################################################
+
+echo PHYSIQUE $phys
+echo dynamique $dyn $dimension
+echo OPTIM90="$optim90" $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=pgf90
+   set f90=pgf90
+else if $SUN then
+   set f77=f90
+   set f90=f90
+else if $NEC then
+   set f77=f90
+   set f90=f90
+else if $XNEC then
+   set f77=sxmpif90
+   set f90=sxmpif90
+else
+   set f77=f77
+   set f90=f90
+endif
+
+cd $model
+
+if $VPP then
+  set make="gmake RANLIB=ls"
+else if $CRAY then
+  set make="make RANLIB=ls"
+else if $NEC then
+  set make="make RANLIB=ls"
+else if $LINUX then
+  set make="make -k RANLIB=ranlib"
+else if $XNEC then
+  set make="/usr/local/bin/gmake RANLIB=ls"
+  set make="/usr/freeware/bin/gmake RANLIB=ls"
+else
+  set make="make RANLIB=ranlib"
+endif
+
+
+
+#
+# les deux test suivants sont "temporaires" pour pallier des "faiblesses" du 
+# compilateur fortran Sun: f90: SC4.0 11 Sep 1995 FORTRAN 90 1.1
+#
+#if ($code == 'create_limit' && $SUN) then
+#   set link=f77
+#   set opt_link="-L$NCDFLIB -lnetcdf"
+#endif
+
+#if ($code == 'create_etat0' && $SUN) then
+#   if ( ! -f $libo/libdyn3d.a ) then
+#     echo "Priere de compiler gcm en premier pour des raisons d'optimisation"
+#     \rm $libf/grid/dimensions.h
+#     exit
+#   endif
+#   set 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 optim90="$optim90"" -X9 -w"
+   set opt_link="-L$NCDFLIB -lnetcdf"
+   touch $LMDGCM/libf/dyn3d/startvar.F
+   touch $LMDGCM/libf/dyn3d/etat0_netcdf.F
+endif
+
+#
+# etat0_netcdf a besoin d'info de la physique
+# A revoir
+set include="$include"" -I$libf/phy$physique"
+
+
+#################################################################
+# Execution de la comande make... ENFIN!
+#################################################################
+
+if $VPP then
+  set optim90=" $optim90 -Am -M$libo"
+  set optimtru90="$optim90"
+else if $SUN then
+ set optim90=" $optim90 -M$libo"
+ set optimtru90=" $optimtru90 "
+else if $NEC then
+ set optim90=" $optim90 -I$libo "
+else if $XNEC then
+ set optim90=" $optim90 -I$libo "
+ set optimtru90=" $optimtru90 -I$libo "
+else if $LINUX then
+ set optim90="$optim90 -module $libo"
+ set mod_loc_dir=$libo
+endif
+
+set link="$f90 $optim90"
+
+set ar=ar
+
+if $XNEC then
+  set link="sxld $opt_link"
+  set link="$f90 "
+#  set ar=sxar
+endif
+
+
+cd $localdir
+
+echo $make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+DYNTYPE="$dyntype" \
+L_ADJNT="$adjnt" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+
+$make -f $LMDGCM/makefile \
+OPTION_DEP="$opt_dep" OPTION_LINK="$opt_link" \
+OPTIM90="$optim90" \
+OPTIMTRU90="$optimtru90" \
+INCLUDE="$include" \
+$filtre \
+LIBO=$libo \
+$dyn \
+$phys \
+DIM=$dimc \
+DYNTYPE="$dyntype" \
+L_ADJNT="$adjnt" \
+LOCAL_DIR="$localdir"  \
+F77="$f77" \
+F90="$f90" \
+OPLINK="$oplink" \
+LINK="$link" \
+GCM="$LMDGCM" \
+MOD_LOC_DIR=$mod_loc_dir \
+MOD_SUFFIX=$mod_suffix \
+AR=$ar \
+PROG=$code
+
+\rm $libf/grid/dimensions.h
Index: trunk/mesoscale/LMDZ.MARS/myGCM/callphys.def
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/callphys.def	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/callphys.def	(revision 57)
@@ -0,0 +1,1 @@
+link ../in_lmdz_mars/myGCM/callphys.def
Index: trunk/mesoscale/LMDZ.MARS/myGCM/diagfi.nc
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/diagfi.nc	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/diagfi.nc	(revision 57)
@@ -0,0 +1,1 @@
+link /donnees/aslmd/MODELES//TMPDIR/GCMINI/diagfi.nc
Index: trunk/mesoscale/LMDZ.MARS/myGCM/gcm.e
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/gcm.e	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/gcm.e	(revision 57)
@@ -0,0 +1,1 @@
+link ../gcm.e
Index: trunk/mesoscale/LMDZ.MARS/myGCM/launch_gcm
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/launch_gcm	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/launch_gcm	(revision 57)
@@ -0,0 +1,1 @@
+link ../in_lmdz_mars/myGCM/launch_gcm
Index: trunk/mesoscale/LMDZ.MARS/myGCM/log_gcm
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/log_gcm	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/log_gcm	(revision 57)
@@ -0,0 +1,2844 @@
+  Choix du shema  Van-Leer  pour la vapeur d'eau
+ rad,omeg,g,cpp,kappa    3397200.       7.0776514E-05    3.720000     
+    744.4990       0.2567930    
+ DEFRUN: reading file run.def
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+  nday              10
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min ) 
+  day_step         960
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod            5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser           40
+
+- periode d'ecriture du fichier histoire (en jour)                      
+  iecri not used
+
+- periode de stockage fichier histmoy (en jour)                         
+  periodav      60.000
+
+- periode de la dissipation (en pas)                                    
+  idissip            5
+
+- choix de l'operateur de dissipation (star ou  non star )              
+  lstardis           T
+
+- avec ou sans coordonnee hybrides                                      
+      hybrid         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    4000.000
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+  tetagrot    5000.000
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+  tetatemp    5000.000
+
+- coefficient pour gamdissip                                            
+  coefdis        0.000
+
+- 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           20
+
+- choix d'une grille reguliere                                          
+  grireg             T
+
+- frequence (en pas) de l'ecriture du fichier diagfi                    
+  ecritphy      40.000
+
+- longitude en degres du centre du zoom                                 
+  clon          63.000
+
+- latitude en degres du centre du zoom                                  
+  clat           0.000
+
+- facteur de grossissement du zoom,selon longitude                      
+  grossismx      1.000
+
+- facteur de grossissement du zoom ,selon latitude                      
+  grossismy      1.000
+  Defrun  alphax alphay      0.000000        0.000000    
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale      
+    fxyhypb          F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone tota
+    dzoomx       0.000
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone total
+    dzoomy       0.000
+
+-  raideur du zoom en  X                                                
+     taux
+    2.000000    
+
+-  raideur du zoom en  Y                                                
+     tauy
+    2.000000    
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit. 
+   ysinus
+  F
+
+- Avec sponge layer                                                     
+  callsponge         T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)        
+  mode_sponge        2
+
+- Sponge:  hauteur de sponge (km)                                       
+  hsponge       90.000
+
+- Sponge:  tetasponge (secondes)                                        
+  tetasponge 50000.000
+ -----------------------------------------------
+  
+  
+ -----------------------------------------------
+  
+  
+ No zoom ? -> fxyhypb set to False           (It runs better that way)
+  R  CPP  Kappa     191.1821        744.4990       0.2567930    
+ ****************************
+ Lecture de z2sig.def
+ ****************************
+ *******************************
+ Systeme en coordonnees hybrides
+
+  BP 
+    1.000000       0.9988748       0.9970348       0.9929134     
+   0.9834716       0.9656457       0.9330362       0.8748387     
+   0.7799573       0.6445467       0.4819302       0.3212751     
+   0.1906131       0.1010640       4.7360588E-02   1.7974662E-02 
+   3.4432942E-03   1.1517399E-07   3.4319594E-30    0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000    
+  AP 
+    0.000000       1.1254549E-02   2.9673576E-02   7.0990324E-02 
+   0.1659572       0.3464091       0.6802320        1.286786     
+    2.300025        3.780318        5.567308        7.260750     
+    8.456269        9.001724        8.990911        8.568018     
+    7.674395        4.854020        2.410436        1.196987     
+   0.5944065       0.2951735       0.1465788       7.2788894E-02 
+   3.6145877E-02    0.000000    
+  BPs 
+   0.9994375       0.9979548       0.9949741       0.9881925     
+   0.9745587       0.9493409       0.9039375       0.8273980     
+   0.7122520       0.5632384       0.4016027       0.2559441     
+   0.1458385       7.4212275E-02   3.2667626E-02   1.0708978E-02 
+   1.7217047E-03   5.7586995E-08   1.7159797E-30    0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000    
+  APs
+   5.6272745E-03   2.0464063E-02   5.0331950E-02   0.1184738     
+   0.2561831       0.5133206       0.9835088        1.793405     
+    3.040172        4.673813        6.414029        7.858510     
+    8.728996        8.996318        8.779465        8.121206     
+    6.264207        3.632228        1.803712       0.8956968     
+   0.4447900       0.2208762       0.1096839       5.4467387E-02 
+   2.7047699E-02
+  PRESNIVS
+    609.6625        608.7729        606.9846        602.9159     
+    594.7369        579.6113        552.3854        506.5062     
+    437.5139        348.2493        251.3916        163.9844     
+    97.69050        54.26581        28.70672        14.65368     
+    7.314447        3.632263        1.803712       0.8956968     
+   0.4447900       0.2208762       0.1096839       5.4467387E-02 
+   2.7047699E-02
+ Pseudo altitude des Presnivs : 
+   5.5346307E-03   2.0136829E-02   4.9556300E-02   0.1168127     
+   0.2533979       0.5110133       0.9921298        1.859224     
+    3.323505        5.605404        8.864469        13.13688     
+    18.31655        24.19565        30.56328        37.28767     
+    44.23607        51.23603        58.23612        65.23612     
+    72.23611        79.23612        86.23612        93.23611     
+    100.2361    
+
+
+           ....  INIGEOM  date du 01/06/98   ..... 
+
+        Calcul des elongations cu et cv  comme sommes des 4 
+      elong. cuij1, .. 4  , cvij1,.. 4  qui les entourent , aux   
+      memes endroits que les aires aireij1,...j4   . 
+
+  gamdi_gd     0.000000        0.000000        0.000000        0.000000     
+            1            2            2
+
+
+
+ *** Inigeom ,  Y = Latitude  , der. sinusoid . ***
+    ***  Coordonnees de la grille  *** 
+
+
+    LONGITUDES  aux pts.   V  ( degres )  
+
+
+  -180.00 -174.38 -168.75 -163.12 -157.50 -151.88 -146.25 -140.63
+  -135.00 -129.38 -123.75 -118.13 -112.50 -106.88 -101.25  -95.63
+   -90.00  -84.37  -78.75  -73.13  -67.50  -61.87  -56.25  -50.63
+   -45.00  -39.38  -33.75  -28.12  -22.50  -16.88  -11.25   -5.63
+     0.00    5.63   11.25   16.88   22.50   28.12   33.75   39.38
+    45.00   50.62   56.25   61.87   67.50   73.13   78.75   84.38
+    90.00   95.63  101.25  106.88  112.50  118.12  123.75  129.38
+   135.00  140.63  146.25  151.88  157.50  163.13  168.75  174.38
+   180.00
+
+
+    LATITUDES   aux pts.   V  ( degres )  
+
+
+    88.13   84.37   80.63   76.88   73.13   69.38   65.63   61.88
+    58.12   54.38   50.63   46.88   43.13   39.38   35.63   31.87
+    28.13   24.38   20.63   16.88   13.13    9.38    5.63    1.88
+    -1.87   -5.62   -9.38  -13.13  -16.88  -20.63  -24.37  -28.12
+   -31.87  -35.63  -39.38  -43.13  -46.88  -50.62  -54.37  -58.12
+   -61.87  -65.63  -69.37  -73.13  -76.88  -80.63  -84.37  -88.12
+
+
+    LONGITUDES  aux pts.   U  ( degres )  
+
+
+  -177.19 -171.56 -165.94 -160.31 -154.69 -149.06 -143.44 -137.81
+  -132.19 -126.56 -120.94 -115.31 -109.69 -104.06  -98.44  -92.81
+   -87.19  -81.56  -75.94  -70.31  -64.69  -59.06  -53.44  -47.81
+   -42.19  -36.56  -30.94  -25.31  -19.69  -14.06   -8.44   -2.81
+     2.81    8.44   14.06   19.69   25.31   30.94   36.56   42.19
+    47.81   53.44   59.06   64.69   70.31   75.94   81.56   87.19
+    92.81   98.44  104.06  109.69  115.31  120.94  126.56  132.19
+   137.81  143.44  149.06  154.69  160.31  165.94  171.56  177.19
+   182.81
+
+
+    LATITUDES   aux pts.   U  ( degres )  
+
+
+    90.00   86.25   82.50   78.75   75.00   71.25   67.50   63.75
+    60.00   56.25   52.50   48.75   45.00   41.25   37.50   33.75
+    30.00   26.25   22.50   18.75   15.00   11.25    7.50    3.75
+     0.00   -3.75   -7.50  -11.25  -15.00  -18.75  -22.50  -26.25
+   -30.00  -33.75  -37.50  -41.25  -45.00  -48.75  -52.50  -56.25
+   -60.00  -63.75  -67.50  -71.25  -75.00  -78.75  -82.50  -86.25
+   -90.00
+
+
+  EIGNVL 
+ -0.286828E-05-0.999188E+00-0.999195E+00-0.398716E+01-0.398717E+01
+ -0.893513E+01-0.893514E+01-0.157954E+02-0.157955E+02-0.245020E+02
+ -0.245020E+02-0.349710E+02-0.349711E+02-0.471016E+02-0.471017E+02
+ -0.607770E+02-0.607771E+02-0.758655E+02-0.758655E+02-0.922217E+02
+ -0.922217E+02-0.109688E+03-0.109688E+03-0.128097E+03-0.128097E+03
+ -0.147270E+03-0.147270E+03-0.167023E+03-0.167023E+03-0.187167E+03
+ -0.187167E+03-0.207506E+03-0.207506E+03-0.227845E+03-0.227845E+03
+ -0.247988E+03-0.247988E+03-0.267742E+03-0.267742E+03-0.286915E+03
+ -0.286915E+03-0.305323E+03-0.305323E+03-0.322790E+03-0.322790E+03
+ -0.339146E+03-0.339146E+03-0.354234E+03-0.354235E+03-0.367910E+03
+ -0.367910E+03-0.380040E+03-0.380041E+03-0.390509E+03-0.390510E+03
+ -0.399216E+03-0.399216E+03-0.406076E+03-0.406076E+03-0.411024E+03
+ -0.411024E+03-0.414012E+03-0.414012E+03-0.415012E+03
+
+                Inifilr colat0 alphax    0.5000000E+00   0.0000000E+00
+  TRUNCATION AT            64
+  jfiltnv jfiltsv jfiltnu jfiltsu             8           41            9 
+           41
+    Modes premiers  v  
+   4 10 14 20 26 32 40 52 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64
+  64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 52 40 32 26 20 14 10  4
+    Modes premiers  u  
+  64  6 12 18 24 30 36 46 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64
+  64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 64 46 36 30 24 18 12  6
+  le parametre nfilun utilise pour la matrice 
+  matriceun est trop grand ! Gachis de memoire ! 
+ Le changer dans parafilt.h et le mettre a              9
+  Pour information, nfilun,nfilus,nfilvn,nfilvs 
+ doivent etre egaux successivement a              9            8            8 
+            8
+  le parametre nfilus utilise pour la matrice  matriceus  est trop grand ! 
+  Le changer dans parafilt.h et le mettre a              8
+  Pour information , nfilun,nfilus,nfilvn,nfilvs 
+ doivent etre egaux successivement a              9            8            8 
+            8
+  le parametre nfilvn utilise pour la matrice 
+  matricevn est trop grand !  Gachis de memoire ! 
+ Le changer dans parafilt.h et le mettre a              8
+  Pour information , nfilun,nfilus,nfilvn,nfilvs 
+ doivent etre egaux successivement a              9            8            8 
+            8
+  le parametre nfilvs utilise pour la matrice 
+  matricevs  est trop grand ! Gachis de memoire ! 
+  Le changer dans parafilt.h et le mettre a              8
+  Pour information , nfilun,nfilus,nfilvn,nfilvs 
+ doivent etre egaux successivement a              9            8            8 
+            8
+ Dissipation : 
+ Multiplication de la dissipation en altitude : fac_mid, fac_up = 
+    2.000000        10.00000    
+ Transition mid /up : startalt, delta =    90.00000        20.00000     (km)
+ calcul des valeurs propres
+ Constantes de temps de la diffusion horizontale
+  INIDI tetamin dtvr     636.6514        92.47396                5
+  INIDI tetamin idissip     636.6514                5
+  INIDI idissip dtdiss             5    462.3698    
+ pseudoZ(km)  zvert  dt(tetagdiv) dt(tetagrot) dt(divgrad)
+   5.5346307E-03    1.000000       0.1155925       9.2473991E-02 
+   9.2473991E-02
+   2.0136829E-02    1.000004       0.1155929       9.2474334E-02 
+   9.2474334E-02
+   4.9556300E-02    1.000025       0.1155953       9.2476241E-02 
+   9.2476241E-02
+   0.1168127        1.000138       0.1156084       9.2486732E-02 
+   9.2486732E-02
+   0.2533979        1.000658       0.1156685       9.2534840E-02 
+   9.2534840E-02
+   0.5110133        1.002741       0.1159093       9.2727467E-02 
+   9.2727467E-02
+   0.9921298        1.010762       0.1168364       9.3469143E-02 
+   9.3469143E-02
+    1.859224        1.040077       0.1202251       9.6180052E-02 
+   9.6180052E-02
+    3.323505        1.134519       0.1311418       0.1049134     
+   0.1049134    
+    5.605404        1.360994       0.1573206       0.1258565     
+   0.1258565    
+    8.864469        1.670498       0.1930970       0.1544776     
+   0.1544776    
+    13.13688        1.880919       0.2174201       0.1739361     
+   0.1739361    
+    18.31655        1.964914       0.2271293       0.1817034     
+   0.1817034    
+    24.19565        1.990555       0.2300932       0.1840745     
+   0.1840745    
+    30.56328        1.997567       0.2309037       0.1847229     
+   0.1847229    
+    37.28767        1.999395       0.2311149       0.1848919     
+   0.1848919    
+    44.23607        1.999853       0.2311679       0.1849343     
+   0.1849343    
+    51.23603        1.999964       0.2311807       0.1849446     
+   0.1849446    
+    58.23612        1.999991       0.2311839       0.1849471     
+   0.1849471    
+    65.23612        1.999998       0.2311846       0.1849477     
+   0.1849477    
+    72.23611        2.000000       0.2311849       0.1849479     
+   0.1849479    
+    79.23612        2.000031       0.2311885       0.1849508     
+   0.1849508    
+    86.23612        2.002072       0.2314245       0.1851396     
+   0.1851396    
+    93.23611        2.135875       0.2468910       0.1975128     
+   0.1975128    
+    100.2361        6.282874       0.7262527       0.5810022     
+   0.5810022    
+ PRESSION SURFACE
+ MIN:     147.3642    
+ MAX:     1292.471    
+55555555555555555555555555555555555555555555555555555555555555555
+55555555555555555555555555556555555555555555555555555555555555555
+66666666666666666666666666666655555555555666666666666666666666666
+66666666666666666666666666666666666666666666666666666666666666666
+66666666666666666666666666666666666666666666666666666666666666666
+66666666666666666666666666666666666666666666666666666666666666666
+66666666666666666666666666666666666666666666666666666666666666666
+66666666655555555666666666666666666666666666666666666666666666666
+66666665555555555556666666666666666666666666666666666666666666666
+66666655555555445555666666666666666666666666556666666666666666666
+66666655555444444555556666666666666666555555556666666666666666666
+66666655554444444445455666666666666666555555556666666666666666666
+66666655544322344333445566666666665555555555555666666666666665666
+66666665543222333333444566666666555555544455555666666666666655666
+66666665443222333333444556666665555554444445555566666666666555666
+66666665543322333333444556666655555444444444445566666666665555666
+66666655443323333334455556666555555444444444345556666666644445566
+66666655443322333334455566655555555444444433334556666666532445556
+55666654233333333444444566555555545444443333334555566666533445555
+55566654023333333444444556555554444444443333345555555566543445555
+55566654133332233344444556555454444444443333345655555555544455555
+55555554433331123344444455555555444444433333335665544555555555555
+55555554432221223343344445555554444443433333334665444455555555555
+55555554332222223333333444555554444443333333334554444345555555555
+55554554332112222332333344545554444433333333333333344344555555555
+55554544322111122223233334554544444433333333333333344333555555555
+44554443321011122234323445554444444333333333333333333333444455544
+44444433321111112224433345545444443333333333333333333333333445554
+33444333321111112222234554444444433333333333333333333333333344443
+33343333322221122222223333454444433333333334433333333333333334433
+33333333332222222232223333444444333333333344444333333333333333333
+33333333332222122232223333444433333333333345554444333333333333333
+33333333332222122222233334444333333333333468885544433333333333333
+333333333322221222223333334443333333333336**998655433333333333343
+434333333332222222223333444433333333333359**999875433333333333344
+3333433333333322222223345544433333333333599**99876443333333333333
+333333333333333333223344665433333333333459*9999985443333333333333
+33433333333333223332334666543333333333345789999864433333333333333
+33333333333333233333334666543333333333344568887644333333333333333
+33333333333333333343334455344333333333334444555443333333333333333
+33333333333333333333333433433333333333333333344333333333333333333
+33333333333333333333333333333333333333333333333333333333333333333
+33333333333333333333333333333333333333333333333332233333333333333
+33333333333333333333333333333333333333333333333333333333333333333
+33333333333333333333333333333333333333333322233333233333222222233
+22222232233333333233333333333333332233333333333333333333222222222
+22222222222222222223333333333322222222223333222233322222222222222
+22222222222222222222222222222222222222222222222222222222222222222
+22222222222222222222222222222222222222222222222222222222222222222
+1
+               run du pas      0  au pas   9600  c'est a dire du jour    216   au jour    226
+
+
+ iim,jjm,llm,idayref           64           48           25          226
+ rad,omeg,g,cpp,kappa    3397200.       7.0776514E-05    3.720000     
+    744.4990       0.2567930    
+ gcm: callgroupeun set to:  T
+  ----   Test_period apres continue   OK ! -----            0
+ in groupeun.F, ngroup=            2
+0**********    pas      0     jour 216.heure  0.0    date   0.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990732 0.126226E+01     0.954     0.730     0.952    11.372     0.955
+
+ Shema  Amont nouveau  appele dans  Vanleer   
+
+ sponge mode            2
+ hsponge tetasponge     90.00000        50000.00    
+ Coeffs pour la couche en eponge
+ Z (km)  tau
+   5.5352268E-03   1.6777216E+12   2.7559388E-10
+   2.0136829E-02   1.6777216E+12   2.7559388E-10
+   4.9556300E-02   1.6777216E+12   2.7559388E-10
+   0.1168121       1.6777216E+12   2.7559388E-10
+   0.2533973       1.6777216E+12   2.7559388E-10
+   0.5110127       1.6777216E+12   2.7559388E-10
+   0.9921304       1.6777216E+12   2.7559388E-10
+    1.859224       1.6777216E+12   2.7559388E-10
+    3.323505       1.6777216E+12   2.7559388E-10
+    5.605404       8.3886080E+11   5.5118776E-10
+    8.864469       5.5924058E+11   8.2678164E-10
+    13.13688       2.3967452E+11   1.9291571E-09
+    18.31655       8.3886080E+10   5.5118776E-09
+    24.19565       2.5811102E+10   1.7913601E-08
+    30.56328       7.2628639E+09   6.3662192E-08
+    37.28767       1.8935910E+09   2.4417619E-07
+    44.23607       4.7206573E+08   9.7946065E-07
+    51.23603       1.1645183E+08   3.9704810E-06
+    58.23612       2.8754206E+07   1.6080077E-05
+    65.23612        7128382.       6.4863227E-05
+    72.23611        1795507.       2.5751494E-04
+    79.23612        480435.9       9.6239644E-04
+    86.23612        156144.2       2.9611716E-03
+    93.23611        76174.88       6.0698460E-03
+    104.2680        52881.84       8.7434519E-03
+
+
+
+ --------------------------------------------
+  Parametres pour la physique (callphys.def)
+ --------------------------------------------
+    tracer    (R       F
+    diurnal   (D       T
+    season    (S       T
+    lwrite    (w       F
+    stats     (S       F
+    calleofdump        F
+    iaervar  (=1       4
+    iddist  (Dus       3
+    topdustref (    55.0
+    callrad   (c       T
+    callnlte (ca       T
+    callnirco2 (       T
+    calldifv  (c       T
+    calladj   (c       T
+    callcond  (c       T
+    callsoil  (c       T
+    calllott  (c       T
+    iradia    (t       1
+    callg2d   (O       F
+    rayleigh  (R       F
+    dustbin    (       0
+    active     (       F
+    doubleq    (       F
+    lifting    (       F
+    dustdevil  (       F
+    scavenging (       F
+    sedimentatio       F
+    iceparty   (       F
+    activice   (       F
+    water      (       F
+    caps       (       F
+    photochem  (       F
+    callthermos        F
+    thermoswater       F
+    callconduct        F
+    calleuv  (ca       F
+    callmolvis         F
+    callmoldiff        F
+    thermochem         F
+ solarcondate    1993.400    
+ --------------------------------------------
+
+
+
+ daysec    88775.00    
+
+ The radiative transfer is computed:
+            each             1  physical time-step
+         or each     1849.479      seconds
+
+
+ TABFI de phyeta0            0            0
+ tab_cntrl    3010.000        25.00000        216.0000        0.000000     
+    3397200.       7.0776514E-05    3.720000        43.49000     
+   0.2566536        88775.00        1849.479        0.000000     
+    0.000000        669.0000        206.6600        249.2200     
+    485.0000        25.19000       9.9999998E-03    30.00000     
+   1.0000000E-06   0.5800000       0.5600000       0.7500000     
+   0.8500000       0.9500000        1.000000        0.000000     
+    0.000000        0.000000       9.9999997E-05   9.9999997E-05 
+   0.5000000       0.5000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000     
+    0.000000        0.000000        0.000000        0.000000    
+ IN tabfi day_ini=          216
+ *****************************************************
+ lecture du tab_cntrl a l appel de tabfi avant modif
+ *****************************************************
+ (1)      = ngridmx?     3010.00     3010.00
+ (2)            lmax       25.00       25.00
+ (3)         day_ini      216.00      216.00
+ (5)             rad  3397200.00  3397200.00
+ (10)         daysec    88775.00    88775.00
+ (6)            omeg   0.707765E-04   0.707765E-04
+ (7)               g        3.72        3.72
+ (8)           mugaz       43.49       43.49
+ (9)             rcp        0.26        0.26
+ (11)        dtphys?   0.184948E+04   0.184948E+04
+ (14)       year_day      669.00      669.00
+ (15)       periheli      206.66      206.66
+ (16)        aphelie      249.22      249.22
+ (17)       peri_day      485.00      485.00
+ (18)       obliquit       25.19       25.19
+ (19)             z0   0.100000E-01   0.100000E-01
+ (21)      emin_turb   0.100000E-05   0.100000E-05
+ (20)        lmixmin       30.00       30.00
+ (26)        emissiv        0.95        0.95
+ (24)     emisice(1)        0.75        0.75
+ (25)     emisice(2)        0.85        0.85
+ (22)    albedice(1)        0.58        0.58
+ (23)    albedice(2)        0.56        0.56
+ (31)   iceradius(1)   0.100000E-03   0.100000E-03
+ (32)   iceradius(2)   0.100000E-03   0.100000E-03
+ (33)   dtemisice(1)        0.50        0.50
+ (34)   dtemisice(2)        0.50        0.50
+ (27)         tauvis        1.00        1.00
+
+ Lmodif dans tabfi!!!!!!!            0
+ Aires des mailles <area>:   6.0666374E+08   7.4146841E+10
+ Geopotentiel au sol <phisfi>:   -26336.29        52485.25    
+ Albedo du sol nu <albedodat>:   0.1091403       0.4468307    
+ Inertie thermique du sol <inertiedat>:    49.35619        1561.128    
+ <zmea>:   -7079.710        14109.68    
+ <zstd>:    8.602325        5754.308    
+ <zsig>:   1.4299651E-04   6.9831915E-02
+ <zgam>:   1.0000000E-07    1.000000    
+ <zthe>:   -89.90438        89.88922    
+ CO2 ice cover <co2ice>:    0.000000        1040.505    
+ phyetat0: Le champ <tsurf> est present
+           J ignore donc les autres temperatures TS**
+ Temperature du sol <tsurf>    143.4214        284.9084    
+ Temperatures du sol profond <tsoil>    141.0773        281.9488    
+ Surface emissivity <emis>:   0.5402458       0.9500000    
+ pbl wind variance <q2>:   1.0000000E-03    26.14403    
+ tracer on surface <qsurf01>:  -1.4551915E-11    27.13205    
+ In physiq day_ini =          216
+ minimum des donnees albedo   0.1091403    
+ maximum des donnees albedo   0.4468307    
+ minimum des donnees albedo   0.1091403    
+ maximum des donnees albedo   0.5600000    
+ Perihelie en Mkm      206.6600    
+ Aphelise  en Mkm      249.2200    
+ obliquite en degres  :    25.19000    
+ e_elips   9.3357898E-02
+ p_elips    1.510404    
+ zanom      1.728111    
+ zx0       1.818617    
+ longitude solaire du perihelie timeperi =     1.908231    
+ full layers, intermediate layers (secoonds)
+    672.3456        887.7498    
+    7558.940        7989.749    
+    42638.13        43499.75    
+    198020.5        199743.7    
+    849681.1        853127.5    
+    3516586.        3523480.    
+   1.4304732E+07   1.4318517E+07
+   5.7698364E+07   5.7725932E+07
+   2.3175499E+08   2.3181013E+08
+   9.2894566E+08   9.2905600E+08
+ Viking Lander 1 GCM point: lat,lon    22.50000       -50.62501    
+ nlthermeq: transition to NLTE centred at   0.10Pa
+               half-width (scale heights)   0.50
+          suggested LTE coverage at least   0.04Pa
+ LTE rad. calculations up to layer            24
+ Call test 9 micron
+ OK test 9 micron
+ PURE DUST PROPERTIES :
+
+ Rapport Solaire/IR :    2.000000    
+
+ Les donnees spectrales :
+ Solaire (SW) ---->
+ <Qext>/Qext(0.67um) ; omega ; g
+    1.000000       0.9200004       0.5499998    
+    1.000000       0.9200006       0.5500003    
+ Thermal IR (LW) ---->
+ <Qext>/Qext(0.67um) ; omega ; g
+   0.2527431       0.4700493       0.5284583    
+   0.2527431       0.4700493       0.5284583    
+   0.4056574       0.5409428       0.5509884    
+   0.1659023       0.3697317       0.3616873    
+ Dans le co2 on prend <Qabs>/Qext(0.67um) =   0.1339414    
+
+ Splitting radiative calculations:  ngridmx,ngrid,ndomainsz,ndomain 
+         3010         3010         3010            1
+ In sugwd NKTOPG=            7
+ In vdifc: Tcond(P=1mb)=    136.2700      Lcond=    590000.0    
+ acond,bcond,ccond   3.2403751E-04   7.3383721E-03   3.2403751E-04
+ In newcondens:Tcond(P=1mb)=    136.2700      Lcond=    590000.0    
+ acond,bcond,ccond   3.2403751E-04   7.3383721E-03   3.2403751E-04
+ Ls =    100.2961      tauref(700 Pa,lat=0) =   0.1463582      tau(Viking1) = 
+   0.1404238    
+ iniwrite: iim,jjm,llm,idayref           64           48           25 
+          216
+ iniwrite: rad,omeg,g,mugaz,rcp    3397200.       7.0776514E-05    3.720000    
+     43.49000       0.2566536    
+ iniwrite: daysec,dtphys    88775.00        1849.479    
+ Ls =    100.3057      tauref(700 Pa,lat=0) =   0.1466529      tau(Viking1) = 
+   0.1407059    
+ WRITEDIAGFI: date=    4.1666668E-02
+ ==========================
+ DIAGFI: creating variable emis
+ ==========================
+ DIAGFI: creating variable tsurf
+ ==========================
+ DIAGFI: creating variable ps
+ ==========================
+ DIAGFI: creating variable co2ice
+ ==========================
+ DIAGFI: creating variable temp
+ ==========================
+ DIAGFI: creating variable u
+ ==========================
+ DIAGFI: creating variable v
+ ==========================
+ DIAGFI: creating variable w
+ ==========================
+ DIAGFI: creating variable tsoil
+0**********    pas     40     jour 216.heure  1.0    date   0.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990667 0.127817E+01     0.954     0.714     0.952    11.419     0.955
+
+ Ls =    100.3153      tauref(700 Pa,lat=0) =   0.1469478      tau(Viking1) = 
+   0.1409688    
+ Ls =    100.3248      tauref(700 Pa,lat=0) =   0.1472426      tau(Viking1) = 
+   0.1412475    
+ WRITEDIAGFI: date=    8.3333336E-02
+0**********    pas     80     jour 216.heure  2.0    date   0.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990609 0.126569E+01     0.954     0.705     0.951    11.447     0.955
+
+ Ls =    100.3344      tauref(700 Pa,lat=0) =   0.1475373      tau(Viking1) = 
+   0.1415209    
+ Ls =    100.3440      tauref(700 Pa,lat=0) =   0.1478322      tau(Viking1) = 
+   0.1417883    
+ WRITEDIAGFI: date=    0.1250000    
+0**********    pas    120     jour 216.heure  3.0    date   0.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990547 0.123867E+01     0.954     0.712     0.951    11.456     0.955
+
+ Ls =    100.3536      tauref(700 Pa,lat=0) =   0.1481270      tau(Viking1) = 
+   0.1420319    
+ Ls =    100.3632      tauref(700 Pa,lat=0) =   0.1484217      tau(Viking1) = 
+   0.1422384    
+ WRITEDIAGFI: date=    0.1666667    
+0**********    pas    160     jour 216.heure  4.0    date   0.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990486 0.121184E+01     0.954     0.708     0.951    11.452     0.955
+
+ Ls =    100.3728      tauref(700 Pa,lat=0) =   0.1487167      tau(Viking1) = 
+   0.1423744    
+ Ls =    100.3824      tauref(700 Pa,lat=0) =   0.1490114      tau(Viking1) = 
+   0.1424361    
+ WRITEDIAGFI: date=    0.2083333    
+0**********    pas    200     jour 216.heure  5.0    date   0.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990427 0.120112E+01     0.954     0.707     0.951    11.439     0.955
+
+ Ls =    100.3920      tauref(700 Pa,lat=0) =   0.1493061      tau(Viking1) = 
+   0.1424427    
+ Ls =    100.4016      tauref(700 Pa,lat=0) =   0.1496011      tau(Viking1) = 
+   0.1423567    
+ WRITEDIAGFI: date=    0.2500000    
+0**********    pas    240     jour 216.heure  6.0    date   0.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990367 0.120211E+01     0.953     0.714     0.951    11.422     0.955
+
+ Ls =    100.4112      tauref(700 Pa,lat=0) =   0.1498958      tau(Viking1) = 
+   0.1421952    
+ Ls =    100.4208      tauref(700 Pa,lat=0) =   0.1501905      tau(Viking1) = 
+   0.1420034    
+ WRITEDIAGFI: date=    0.2916667    
+0**********    pas    280     jour 216.heure  7.0    date   0.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990309 0.119794E+01     0.953     0.717     0.951    11.401     0.956
+
+ Ls =    100.4304      tauref(700 Pa,lat=0) =   0.1504855      tau(Viking1) = 
+   0.1418021    
+ Ls =    100.4399      tauref(700 Pa,lat=0) =   0.1507802      tau(Viking1) = 
+   0.1416183    
+ WRITEDIAGFI: date=    0.3333333    
+0**********    pas    320     jour 216.heure  8.0    date   0.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990250 0.118481E+01     0.953     0.720     0.951    11.378     0.956
+
+ Ls =    100.4495      tauref(700 Pa,lat=0) =   0.1510749      tau(Viking1) = 
+   0.1414731    
+ Ls =    100.4591      tauref(700 Pa,lat=0) =   0.1513699      tau(Viking1) = 
+   0.1414095    
+ WRITEDIAGFI: date=    0.3750000    
+0**********    pas    360     jour 216.heure  9.0    date   0.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990190 0.118279E+01     0.953     0.723     0.951    11.357     0.956
+
+ Ls =    100.4687      tauref(700 Pa,lat=0) =   0.1516646      tau(Viking1) = 
+   0.1412977    
+ Ls =    100.4783      tauref(700 Pa,lat=0) =   0.1519594      tau(Viking1) = 
+   0.1411822    
+ WRITEDIAGFI: date=    0.4166667    
+0**********    pas    400     jour 216.heure 10.0    date   0.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990128 0.120303E+01     0.953     0.735     0.950    11.343     0.955
+
+ Ls =    100.4879      tauref(700 Pa,lat=0) =   0.1522543      tau(Viking1) = 
+   0.1410243    
+ Ls =    100.4975      tauref(700 Pa,lat=0) =   0.1525490      tau(Viking1) = 
+   0.1408765    
+ WRITEDIAGFI: date=    0.4583333    
+0**********    pas    440     jour 216.heure 11.0    date   0.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990068 0.123301E+01     0.953     0.754     0.950    11.336     0.955
+
+ Ls =    100.5071      tauref(700 Pa,lat=0) =   0.1528438      tau(Viking1) = 
+   0.1407440    
+ Ls =    100.5167      tauref(700 Pa,lat=0) =   0.1531387      tau(Viking1) = 
+   0.1406466    
+ WRITEDIAGFI: date=    0.5000000    
+0**********    pas    480     jour 216.heure 12.0    date   0.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.990005 0.124885E+01     0.953     0.771     0.950    11.330     0.955
+
+ Ls =    100.5263      tauref(700 Pa,lat=0) =   0.1534335      tau(Viking1) = 
+   0.1405790    
+ Ls =    100.5359      tauref(700 Pa,lat=0) =   0.1537282      tau(Viking1) = 
+   0.1405267    
+ WRITEDIAGFI: date=    0.5416667    
+0**********    pas    520     jour 216.heure 13.0    date   0.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989940 0.124516E+01     0.953     0.787     0.950    11.320     0.955
+
+ Ls =    100.5455      tauref(700 Pa,lat=0) =   0.1540231      tau(Viking1) = 
+   0.1404602    
+ Ls =    100.5551      tauref(700 Pa,lat=0) =   0.1543179      tau(Viking1) = 
+   0.1403602    
+ WRITEDIAGFI: date=    0.5833333    
+0**********    pas    560     jour 216.heure 14.0    date   0.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989876 0.122300E+01     0.952     0.807     0.950    11.305     0.955
+
+ Ls =    100.5647      tauref(700 Pa,lat=0) =   0.1546126      tau(Viking1) = 
+   0.1402890    
+ Ls =    100.5743      tauref(700 Pa,lat=0) =   0.1549075      tau(Viking1) = 
+   0.1402411    
+ WRITEDIAGFI: date=    0.6250000    
+0**********    pas    600     jour 216.heure 15.0    date   0.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989813 0.120149E+01     0.952     0.820     0.950    11.287     0.955
+
+ Ls =    100.5839      tauref(700 Pa,lat=0) =   0.1552023      tau(Viking1) = 
+   0.1401711    
+ Ls =    100.5935      tauref(700 Pa,lat=0) =   0.1554970      tau(Viking1) = 
+   0.1400447    
+ WRITEDIAGFI: date=    0.6666667    
+0**********    pas    640     jour 216.heure 16.0    date   0.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989748 0.119716E+01     0.952     0.814     0.950    11.270     0.955
+
+ Ls =    100.6030      tauref(700 Pa,lat=0) =   0.1557920      tau(Viking1) = 
+   0.1399024    
+ Ls =    100.6126      tauref(700 Pa,lat=0) =   0.1560867      tau(Viking1) = 
+   0.1397500    
+ WRITEDIAGFI: date=    0.7083333    
+0**********    pas    680     jour 216.heure 17.0    date   0.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989686 0.119232E+01     0.952     0.810     0.950    11.254     0.955
+
+ Ls =    100.6222      tauref(700 Pa,lat=0) =   0.1563814      tau(Viking1) = 
+   0.1395797    
+ Ls =    100.6318      tauref(700 Pa,lat=0) =   0.1566764      tau(Viking1) = 
+   0.1394124    
+ WRITEDIAGFI: date=    0.7500000    
+0**********    pas    720     jour 216.heure 18.0    date   0.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989621 0.118620E+01     0.952     0.813     0.950    11.239     0.955
+
+ Ls =    100.6414      tauref(700 Pa,lat=0) =   0.1569711      tau(Viking1) = 
+   0.1392073    
+ Ls =    100.6511      tauref(700 Pa,lat=0) =   0.1572658      tau(Viking1) = 
+   0.1390109    
+ WRITEDIAGFI: date=    0.7916667    
+0**********    pas    760     jour 216.heure 19.0    date   0.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989559 0.117252E+01     0.952     0.819     0.950    11.230     0.955
+
+ Ls =    100.6606      tauref(700 Pa,lat=0) =   0.1575608      tau(Viking1) = 
+   0.1387900    
+ Ls =    100.6702      tauref(700 Pa,lat=0) =   0.1578555      tau(Viking1) = 
+   0.1385819    
+ WRITEDIAGFI: date=    0.8333333    
+0**********    pas    800     jour 216.heure 20.0    date   0.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989495 0.114975E+01     0.952     0.829     0.950    11.231     0.955
+
+ Ls =    100.6798      tauref(700 Pa,lat=0) =   0.1581502      tau(Viking1) = 
+   0.1384258    
+ Ls =    100.6894      tauref(700 Pa,lat=0) =   0.1584452      tau(Viking1) = 
+   0.1383254    
+ WRITEDIAGFI: date=    0.8750000    
+0**********    pas    840     jour 216.heure 21.0    date   0.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989429 0.114695E+01     0.952     0.851     0.950    11.250     0.954
+
+ Ls =    100.6990      tauref(700 Pa,lat=0) =   0.1587399      tau(Viking1) = 
+   0.1382875    
+ Ls =    100.7086      tauref(700 Pa,lat=0) =   0.1590347      tau(Viking1) = 
+   0.1384511    
+ WRITEDIAGFI: date=    0.9166667    
+0**********    pas    880     jour 216.heure 22.0    date   0.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989364 0.117219E+01     0.952     0.853     0.950    11.290     0.954
+
+ Ls =    100.7182      tauref(700 Pa,lat=0) =   0.1593296      tau(Viking1) = 
+   0.1389739    
+ Ls =    100.7278      tauref(700 Pa,lat=0) =   0.1596244      tau(Viking1) = 
+   0.1396393    
+ WRITEDIAGFI: date=    0.9583333    
+0**********    pas    920     jour 216.heure 23.0    date   0.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989299 0.121485E+01     0.952     0.848     0.950    11.345     0.954
+
+ Ls =    100.7374      tauref(700 Pa,lat=0) =   0.1599191      tau(Viking1) = 
+   0.1399966    
+ Ls =    100.7470      tauref(700 Pa,lat=0) =   0.1602140      tau(Viking1) = 
+   0.1402329    
+ WRITEDIAGFI: date=     1.000000    
+0**********    pas    960     jour 217.heure  0.0    date   1.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989238 0.125502E+01     0.952     0.845     0.950    11.403     0.954
+
+ LTE rad. calculations up to layer            24
+ Ls =    100.7566      tauref(700 Pa,lat=0) =   0.1603885      tau(Viking1) = 
+   0.1406088    
+ Ls =    100.7662      tauref(700 Pa,lat=0) =   0.1605566      tau(Viking1) = 
+   0.1409770    
+ WRITEDIAGFI: date=     1.041667    
+0**********    pas   1000     jour 217.heure  1.0    date   1.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989177 0.127139E+01     0.952     0.823     0.950    11.447     0.954
+
+ Ls =    100.7758      tauref(700 Pa,lat=0) =   0.1607249      tau(Viking1) = 
+   0.1413211    
+ Ls =    100.7854      tauref(700 Pa,lat=0) =   0.1608931      tau(Viking1) = 
+   0.1416653    
+ WRITEDIAGFI: date=     1.083333    
+0**********    pas   1040     jour 217.heure  2.0    date   1.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989116 0.125990E+01     0.952     0.811     0.950    11.472     0.954
+
+ Ls =    100.7950      tauref(700 Pa,lat=0) =   0.1610612      tau(Viking1) = 
+   0.1420065    
+ Ls =    100.8046      tauref(700 Pa,lat=0) =   0.1612295      tau(Viking1) = 
+   0.1423495    
+ WRITEDIAGFI: date=     1.125000    
+0**********    pas   1080     jour 217.heure  3.0    date   1.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.989058 0.123441E+01     0.952     0.801     0.950    11.477     0.954
+
+ Ls =    100.8142      tauref(700 Pa,lat=0) =   0.1613977      tau(Viking1) = 
+   0.1426830    
+ Ls =    100.8238      tauref(700 Pa,lat=0) =   0.1615658      tau(Viking1) = 
+   0.1429625    
+ WRITEDIAGFI: date=     1.166667    
+0**********    pas   1120     jour 217.heure  4.0    date   1.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988996 0.120855E+01     0.952     0.798     0.950    11.469     0.954
+
+ Ls =    100.8334      tauref(700 Pa,lat=0) =   0.1617341      tau(Viking1) = 
+   0.1431684    
+ Ls =    100.8430      tauref(700 Pa,lat=0) =   0.1619022      tau(Viking1) = 
+   0.1432939    
+ WRITEDIAGFI: date=     1.208333    
+0**********    pas   1160     jour 217.heure  5.0    date   1.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988936 0.119987E+01     0.952     0.798     0.950    11.455     0.954
+
+ Ls =    100.8526      tauref(700 Pa,lat=0) =   0.1620704      tau(Viking1) = 
+   0.1433510    
+ Ls =    100.8622      tauref(700 Pa,lat=0) =   0.1622387      tau(Viking1) = 
+   0.1433393    
+ WRITEDIAGFI: date=     1.250000    
+0**********    pas   1200     jour 217.heure  6.0    date   1.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988876 0.120165E+01     0.952     0.794     0.950    11.437     0.954
+
+ Ls =    100.8718      tauref(700 Pa,lat=0) =   0.1624068      tau(Viking1) = 
+   0.1432440    
+ Ls =    100.8814      tauref(700 Pa,lat=0) =   0.1625750      tau(Viking1) = 
+   0.1431012    
+ WRITEDIAGFI: date=     1.291667    
+0**********    pas   1240     jour 217.heure  7.0    date   1.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988817 0.119792E+01     0.952     0.789     0.949    11.416     0.954
+
+ Ls =    100.8910      tauref(700 Pa,lat=0) =   0.1627433      tau(Viking1) = 
+   0.1429395    
+ Ls =    100.9006      tauref(700 Pa,lat=0) =   0.1629114      tau(Viking1) = 
+   0.1428041    
+ WRITEDIAGFI: date=     1.333333    
+0**********    pas   1280     jour 217.heure  8.0    date   1.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988760 0.118461E+01     0.951     0.786     0.949    11.394     0.954
+
+ Ls =    100.9102      tauref(700 Pa,lat=0) =   0.1630796      tau(Viking1) = 
+   0.1427098    
+ Ls =    100.9198      tauref(700 Pa,lat=0) =   0.1632478      tau(Viking1) = 
+   0.1427077    
+ WRITEDIAGFI: date=     1.375000    
+0**********    pas   1320     jour 217.heure  9.0    date   1.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988697 0.118176E+01     0.951     0.786     0.949    11.376     0.954
+
+ Ls =    100.9294      tauref(700 Pa,lat=0) =   0.1634160      tau(Viking1) = 
+   0.1426577    
+ Ls =    100.9390      tauref(700 Pa,lat=0) =   0.1635841      tau(Viking1) = 
+   0.1426106    
+ WRITEDIAGFI: date=     1.416667    
+0**********    pas   1360     jour 217.heure 10.0    date   1.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988638 0.120074E+01     0.951     0.791     0.949    11.367     0.954
+
+ Ls =    100.9486      tauref(700 Pa,lat=0) =   0.1637524      tau(Viking1) = 
+   0.1425267    
+ Ls =    100.9582      tauref(700 Pa,lat=0) =   0.1639206      tau(Viking1) = 
+   0.1424594    
+ WRITEDIAGFI: date=     1.458333    
+0**********    pas   1400     jour 217.heure 11.0    date   1.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988576 0.123146E+01     0.951     0.800     0.949    11.365     0.954
+
+ Ls =    100.9678      tauref(700 Pa,lat=0) =   0.1640887      tau(Viking1) = 
+   0.1424224    
+ Ls =    100.9774      tauref(700 Pa,lat=0) =   0.1642570      tau(Viking1) = 
+   0.1424178    
+ WRITEDIAGFI: date=     1.500000    
+0**********    pas   1440     jour 217.heure 12.0    date   1.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988512 0.124863E+01     0.951     0.804     0.949    11.363     0.954
+
+ Ls =    100.9870      tauref(700 Pa,lat=0) =   0.1644252      tau(Viking1) = 
+   0.1424403    
+ Ls =    100.9966      tauref(700 Pa,lat=0) =   0.1645933      tau(Viking1) = 
+   0.1424717    
+ WRITEDIAGFI: date=     1.541667    
+0**********    pas   1480     jour 217.heure 13.0    date   1.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988451 0.124601E+01     0.951     0.806     0.949    11.354     0.954
+
+ Ls =    101.0062      tauref(700 Pa,lat=0) =   0.1647616      tau(Viking1) = 
+   0.1424929    
+ Ls =    101.0158      tauref(700 Pa,lat=0) =   0.1649298      tau(Viking1) = 
+   0.1424623    
+ WRITEDIAGFI: date=     1.583333    
+0**********    pas   1520     jour 217.heure 14.0    date   1.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988388 0.122490E+01     0.951     0.814     0.949    11.337     0.954
+
+ Ls =    101.0254      tauref(700 Pa,lat=0) =   0.1650979      tau(Viking1) = 
+   0.1424455    
+ Ls =    101.0350      tauref(700 Pa,lat=0) =   0.1652662      tau(Viking1) = 
+   0.1424396    
+ WRITEDIAGFI: date=     1.625000    
+0**********    pas   1560     jour 217.heure 15.0    date   1.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988322 0.120498E+01     0.951     0.821     0.949    11.317     0.954
+
+ Ls =    101.0446      tauref(700 Pa,lat=0) =   0.1654343      tau(Viking1) = 
+   0.1424264    
+ Ls =    101.0542      tauref(700 Pa,lat=0) =   0.1656025      tau(Viking1) = 
+   0.1423633    
+ WRITEDIAGFI: date=     1.666667    
+0**********    pas   1600     jour 217.heure 16.0    date   1.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988257 0.120230E+01     0.951     0.827     0.949    11.298     0.954
+
+ Ls =    101.0638      tauref(700 Pa,lat=0) =   0.1657708      tau(Viking1) = 
+   0.1422767    
+ Ls =    101.0734      tauref(700 Pa,lat=0) =   0.1659389      tau(Viking1) = 
+   0.1421882    
+ WRITEDIAGFI: date=     1.708333    
+0**********    pas   1640     jour 217.heure 17.0    date   1.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988193 0.119881E+01     0.950     0.833     0.949    11.279     0.954
+
+ Ls =    101.0830      tauref(700 Pa,lat=0) =   0.1661071      tau(Viking1) = 
+   0.1420696    
+ Ls =    101.0926      tauref(700 Pa,lat=0) =   0.1662754      tau(Viking1) = 
+   0.1419379    
+ WRITEDIAGFI: date=     1.750000    
+0**********    pas   1680     jour 217.heure 18.0    date   1.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988132 0.119401E+01     0.950     0.854     0.949    11.264     0.954
+
+ Ls =    101.1022      tauref(700 Pa,lat=0) =   0.1664435      tau(Viking1) = 
+   0.1417714    
+ Ls =    101.1118      tauref(700 Pa,lat=0) =   0.1666117      tau(Viking1) = 
+   0.1416261    
+ WRITEDIAGFI: date=     1.791667    
+0**********    pas   1720     jour 217.heure 19.0    date   1.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988068 0.118068E+01     0.950     0.879     0.949    11.254     0.954
+
+ Ls =    101.1215      tauref(700 Pa,lat=0) =   0.1667800      tau(Viking1) = 
+   0.1414549    
+ Ls =    101.1310      tauref(700 Pa,lat=0) =   0.1669481      tau(Viking1) = 
+   0.1413029    
+ WRITEDIAGFI: date=     1.833333    
+0**********    pas   1760     jour 217.heure 20.0    date   1.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.988002 0.115788E+01     0.950     0.901     0.949    11.256     0.954
+
+ Ls =    101.1406      tauref(700 Pa,lat=0) =   0.1671163      tau(Viking1) = 
+   0.1411906    
+ Ls =    101.1502      tauref(700 Pa,lat=0) =   0.1672845      tau(Viking1) = 
+   0.1411401    
+ WRITEDIAGFI: date=     1.875000    
+0**********    pas   1800     jour 217.heure 21.0    date   1.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987939 0.115459E+01     0.950     0.925     0.949    11.276     0.953
+
+ Ls =    101.1598      tauref(700 Pa,lat=0) =   0.1674527      tau(Viking1) = 
+   0.1411794    
+ Ls =    101.1695      tauref(700 Pa,lat=0) =   0.1676209      tau(Viking1) = 
+   0.1414421    
+ WRITEDIAGFI: date=     1.916667    
+0**********    pas   1840     jour 217.heure 22.0    date   1.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987874 0.118065E+01     0.951     0.942     0.949    11.316     0.953
+
+ Ls =    101.1791      tauref(700 Pa,lat=0) =   0.1677891      tau(Viking1) = 
+   0.1420728    
+ Ls =    101.1887      tauref(700 Pa,lat=0) =   0.1679573      tau(Viking1) = 
+   0.1428301    
+ WRITEDIAGFI: date=     1.958333    
+0**********    pas   1880     jour 217.heure 23.0    date   1.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987811 0.122364E+01     0.951     0.943     0.949    11.371     0.953
+
+ Ls =    101.1983      tauref(700 Pa,lat=0) =   0.1681254      tau(Viking1) = 
+   0.1432756    
+ Ls =    101.2079      tauref(700 Pa,lat=0) =   0.1682937      tau(Viking1) = 
+   0.1435863    
+ WRITEDIAGFI: date=     2.000000    
+0**********    pas   1920     jour 218.heure  0.0    date   2.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987748 0.126442E+01     0.951     0.904     0.949    11.427     0.952
+
+ LTE rad. calculations up to layer            24
+ Ls =    101.2175      tauref(700 Pa,lat=0) =   0.1684196      tau(Viking1) = 
+   0.1440888    
+ Ls =    101.2271      tauref(700 Pa,lat=0) =   0.1685433      tau(Viking1) = 
+   0.1445816    
+ WRITEDIAGFI: date=     2.041667    
+0**********    pas   1960     jour 218.heure  1.0    date   2.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987687 0.128137E+01     0.951     0.889     0.949    11.470     0.952
+
+ Ls =    101.2367      tauref(700 Pa,lat=0) =   0.1686671      tau(Viking1) = 
+   0.1450472    
+ Ls =    101.2463      tauref(700 Pa,lat=0) =   0.1687908      tau(Viking1) = 
+   0.1455429    
+ WRITEDIAGFI: date=     2.083333    
+0**********    pas   2000     jour 218.heure  2.0    date   2.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987626 0.127018E+01     0.950     0.855     0.949    11.491     0.952
+
+ Ls =    101.2559      tauref(700 Pa,lat=0) =   0.1689145      tau(Viking1) = 
+   0.1460127    
+ Ls =    101.2655      tauref(700 Pa,lat=0) =   0.1690384      tau(Viking1) = 
+   0.1464768    
+ WRITEDIAGFI: date=     2.125000    
+0**********    pas   2040     jour 218.heure  3.0    date   2.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987564 0.124589E+01     0.950     0.829     0.949    11.492     0.953
+
+ Ls =    101.2751      tauref(700 Pa,lat=0) =   0.1691621      tau(Viking1) = 
+   0.1469321    
+ Ls =    101.2847      tauref(700 Pa,lat=0) =   0.1692858      tau(Viking1) = 
+   0.1473291    
+ WRITEDIAGFI: date=     2.166667    
+0**********    pas   2080     jour 218.heure  4.0    date   2.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987508 0.122173E+01     0.950     0.826     0.948    11.481     0.953
+
+ Ls =    101.2944      tauref(700 Pa,lat=0) =   0.1694096      tau(Viking1) = 
+   0.1476559    
+ Ls =    101.3039      tauref(700 Pa,lat=0) =   0.1695333      tau(Viking1) = 
+   0.1479095    
+ WRITEDIAGFI: date=     2.208333    
+0**********    pas   2120     jour 218.heure  5.0    date   2.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987443 0.121274E+01     0.950     0.815     0.948    11.465     0.953
+
+ Ls =    101.3135      tauref(700 Pa,lat=0) =   0.1696570      tau(Viking1) = 
+   0.1480956    
+ Ls =    101.3232      tauref(700 Pa,lat=0) =   0.1697808      tau(Viking1) = 
+   0.1482219    
+ WRITEDIAGFI: date=     2.250000    
+0**********    pas   2160     jour 218.heure  6.0    date   2.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987387 0.121616E+01     0.950     0.805     0.948    11.448     0.953
+
+ Ls =    101.3328      tauref(700 Pa,lat=0) =   0.1699045      tau(Viking1) = 
+   0.1482575    
+ Ls =    101.3424      tauref(700 Pa,lat=0) =   0.1700282      tau(Viking1) = 
+   0.1482423    
+ WRITEDIAGFI: date=     2.291667    
+0**********    pas   2200     jour 218.heure  7.0    date   2.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987331 0.121253E+01     0.950     0.806     0.948    11.428     0.953
+
+ Ls =    101.3520      tauref(700 Pa,lat=0) =   0.1701520      tau(Viking1) = 
+   0.1482200    
+ Ls =    101.3616      tauref(700 Pa,lat=0) =   0.1702757      tau(Viking1) = 
+   0.1482035    
+ WRITEDIAGFI: date=     2.333333    
+0**********    pas   2240     jour 218.heure  8.0    date   2.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987268 0.119842E+01     0.950     0.798     0.948    11.408     0.953
+
+ Ls =    101.3712      tauref(700 Pa,lat=0) =   0.1703994      tau(Viking1) = 
+   0.1482340    
+ Ls =    101.3808      tauref(700 Pa,lat=0) =   0.1705232      tau(Viking1) = 
+   0.1483627    
+ WRITEDIAGFI: date=     2.375000    
+0**********    pas   2280     jour 218.heure  9.0    date   2.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987209 0.119425E+01     0.950     0.792     0.948    11.392     0.953
+
+ Ls =    101.3904      tauref(700 Pa,lat=0) =   0.1706469      tau(Viking1) = 
+   0.1484508    
+ Ls =    101.4000      tauref(700 Pa,lat=0) =   0.1707706      tau(Viking1) = 
+   0.1485513    
+ WRITEDIAGFI: date=     2.416667    
+0**********    pas   2320     jour 218.heure 10.0    date   2.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987148 0.121273E+01     0.950     0.801     0.948    11.384     0.953
+
+ Ls =    101.4096      tauref(700 Pa,lat=0) =   0.1708944      tau(Viking1) = 
+   0.1485963    
+ Ls =    101.4193      tauref(700 Pa,lat=0) =   0.1710181      tau(Viking1) = 
+   0.1486504    
+ WRITEDIAGFI: date=     2.458333    
+0**********    pas   2360     jour 218.heure 11.0    date   2.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987089 0.124142E+01     0.950     0.806     0.948    11.382     0.953
+
+ Ls =    101.4288      tauref(700 Pa,lat=0) =   0.1711418      tau(Viking1) = 
+   0.1487361    
+ Ls =    101.4385      tauref(700 Pa,lat=0) =   0.1712656      tau(Viking1) = 
+   0.1488563    
+ WRITEDIAGFI: date=     2.500000    
+0**********    pas   2400     jour 218.heure 12.0    date   2.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.987024 0.125741E+01     0.949     0.808     0.948    11.380     0.953
+
+ Ls =    101.4481      tauref(700 Pa,lat=0) =   0.1713893      tau(Viking1) = 
+   0.1490009    
+ Ls =    101.4577      tauref(700 Pa,lat=0) =   0.1715130      tau(Viking1) = 
+   0.1491538    
+ WRITEDIAGFI: date=     2.541667    
+0**********    pas   2440     jour 218.heure 13.0    date   2.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986959 0.125326E+01     0.949     0.818     0.948    11.374     0.953
+
+ Ls =    101.4673      tauref(700 Pa,lat=0) =   0.1716368      tau(Viking1) = 
+   0.1492924    
+ Ls =    101.4769      tauref(700 Pa,lat=0) =   0.1717605      tau(Viking1) = 
+   0.1493870    
+ WRITEDIAGFI: date=     2.583333    
+0**********    pas   2480     jour 218.heure 14.0    date   2.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986898 0.123153E+01     0.949     0.830     0.947    11.361     0.953
+
+ Ls =    101.4865      tauref(700 Pa,lat=0) =   0.1718842      tau(Viking1) = 
+   0.1494885    
+ Ls =    101.4961      tauref(700 Pa,lat=0) =   0.1720080      tau(Viking1) = 
+   0.1495970    
+ WRITEDIAGFI: date=     2.625000    
+0**********    pas   2520     jour 218.heure 15.0    date   2.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986835 0.121215E+01     0.949     0.842     0.947    11.345     0.953
+
+ Ls =    101.5057      tauref(700 Pa,lat=0) =   0.1721317      tau(Viking1) = 
+   0.1496855    
+ Ls =    101.5154      tauref(700 Pa,lat=0) =   0.1722555      tau(Viking1) = 
+   0.1497284    
+ WRITEDIAGFI: date=     2.666667    
+0**********    pas   2560     jour 218.heure 16.0    date   2.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986770 0.120883E+01     0.949     0.847     0.947    11.329     0.953
+
+ Ls =    101.5250      tauref(700 Pa,lat=0) =   0.1723793      tau(Viking1) = 
+   0.1497423    
+ Ls =    101.5346      tauref(700 Pa,lat=0) =   0.1725030      tau(Viking1) = 
+   0.1497620    
+ WRITEDIAGFI: date=     2.708333    
+0**********    pas   2600     jour 218.heure 17.0    date   2.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986709 0.120590E+01     0.949     0.854     0.947    11.312     0.953
+
+ Ls =    101.5442      tauref(700 Pa,lat=0) =   0.1726267      tau(Viking1) = 
+   0.1497551    
+ Ls =    101.5538      tauref(700 Pa,lat=0) =   0.1727505      tau(Viking1) = 
+   0.1497331    
+ WRITEDIAGFI: date=     2.750000    
+0**********    pas   2640     jour 218.heure 18.0    date   2.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986644 0.120195E+01     0.949     0.867     0.947    11.297     0.953
+
+ Ls =    101.5634      tauref(700 Pa,lat=0) =   0.1728742      tau(Viking1) = 
+   0.1496814    
+ Ls =    101.5730      tauref(700 Pa,lat=0) =   0.1729979      tau(Viking1) = 
+   0.1496395    
+ WRITEDIAGFI: date=     2.791667    
+0**********    pas   2680     jour 218.heure 19.0    date   2.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986581 0.118997E+01     0.949     0.890     0.947    11.286     0.953
+
+ Ls =    101.5826      tauref(700 Pa,lat=0) =   0.1731217      tau(Viking1) = 
+   0.1495875    
+ Ls =    101.5922      tauref(700 Pa,lat=0) =   0.1732454      tau(Viking1) = 
+   0.1495578    
+ WRITEDIAGFI: date=     2.833333    
+0**********    pas   2720     jour 218.heure 20.0    date   2.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986516 0.116722E+01     0.949     0.905     0.947    11.285     0.953
+
+ Ls =    101.6018      tauref(700 Pa,lat=0) =   0.1733691      tau(Viking1) = 
+   0.1495792    
+ Ls =    101.6115      tauref(700 Pa,lat=0) =   0.1734929      tau(Viking1) = 
+   0.1496663    
+ WRITEDIAGFI: date=     2.875000    
+0**********    pas   2760     jour 218.heure 21.0    date   2.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986450 0.116357E+01     0.949     0.899     0.947    11.301     0.952
+
+ Ls =    101.6210      tauref(700 Pa,lat=0) =   0.1736166      tau(Viking1) = 
+   0.1498356    
+ Ls =    101.6307      tauref(700 Pa,lat=0) =   0.1737403      tau(Viking1) = 
+   0.1502210    
+ WRITEDIAGFI: date=     2.916667    
+0**********    pas   2800     jour 218.heure 22.0    date   2.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986384 0.118814E+01     0.949     0.894     0.948    11.336     0.952
+
+ Ls =    101.6403      tauref(700 Pa,lat=0) =   0.1738641      tau(Viking1) = 
+   0.1510053    
+ Ls =    101.6499      tauref(700 Pa,lat=0) =   0.1739878      tau(Viking1) = 
+   0.1519441    
+ WRITEDIAGFI: date=     2.958333    
+0**********    pas   2840     jour 218.heure 23.0    date   2.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986319 0.122876E+01     0.949     0.898     0.948    11.385     0.952
+
+ Ls =    101.6595      tauref(700 Pa,lat=0) =   0.1741115      tau(Viking1) = 
+   0.1525406    
+ Ls =    101.6691      tauref(700 Pa,lat=0) =   0.1742353      tau(Viking1) = 
+   0.1529873    
+ WRITEDIAGFI: date=     3.000000    
+0**********    pas   2880     jour 219.heure  0.0    date   3.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986258 0.126710E+01     0.949     0.890     0.948    11.436     0.951
+
+ LTE rad. calculations up to layer            24
+ Ls =    101.6787      tauref(700 Pa,lat=0) =   0.1746308      tau(Viking1) = 
+   0.1535076    
+ Ls =    101.6884      tauref(700 Pa,lat=0) =   0.1750405      tau(Viking1) = 
+   0.1540068    
+ WRITEDIAGFI: date=     3.041667    
+0**********    pas   2920     jour 219.heure  1.0    date   3.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986198 0.128354E+01     0.949     0.879     0.947    11.475     0.951
+
+ Ls =    101.6980      tauref(700 Pa,lat=0) =   0.1754506      tau(Viking1) = 
+   0.1544669    
+ Ls =    101.7076      tauref(700 Pa,lat=0) =   0.1758603      tau(Viking1) = 
+   0.1549566    
+ WRITEDIAGFI: date=     3.083333    
+0**********    pas   2960     jour 219.heure  2.0    date   3.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986136 0.127251E+01     0.949     0.870     0.947    11.494     0.951
+
+ Ls =    101.7172      tauref(700 Pa,lat=0) =   0.1762700      tau(Viking1) = 
+   0.1554042    
+ Ls =    101.7268      tauref(700 Pa,lat=0) =   0.1766801      tau(Viking1) = 
+   0.1558613    
+ WRITEDIAGFI: date=     3.125000    
+0**********    pas   3000     jour 219.heure  3.0    date   3.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986078 0.125034E+01     0.949     0.852     0.947    11.495     0.952
+
+ Ls =    101.7365      tauref(700 Pa,lat=0) =   0.1770898      tau(Viking1) = 
+   0.1563287    
+ Ls =    101.7461      tauref(700 Pa,lat=0) =   0.1774995      tau(Viking1) = 
+   0.1567259    
+ WRITEDIAGFI: date=     3.166667    
+0**********    pas   3040     jour 219.heure  4.0    date   3.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.986018 0.122947E+01     0.949     0.833     0.947    11.485     0.952
+
+ Ls =    101.7557      tauref(700 Pa,lat=0) =   0.1779095      tau(Viking1) = 
+   0.1570446    
+ Ls =    101.7653      tauref(700 Pa,lat=0) =   0.1783193      tau(Viking1) = 
+   0.1572844    
+ WRITEDIAGFI: date=     3.208333    
+0**********    pas   3080     jour 219.heure  5.0    date   3.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985958 0.122421E+01     0.948     0.818     0.947    11.471     0.952
+
+ Ls =    101.7749      tauref(700 Pa,lat=0) =   0.1787290      tau(Viking1) = 
+   0.1574533    
+ Ls =    101.7845      tauref(700 Pa,lat=0) =   0.1791390      tau(Viking1) = 
+   0.1575581    
+ WRITEDIAGFI: date=     3.250000    
+0**********    pas   3120     jour 219.heure  6.0    date   3.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985899 0.123040E+01     0.948     0.816     0.947    11.454     0.952
+
+ Ls =    101.7941      tauref(700 Pa,lat=0) =   0.1795488      tau(Viking1) = 
+   0.1575829    
+ Ls =    101.8037      tauref(700 Pa,lat=0) =   0.1799585      tau(Viking1) = 
+   0.1575392    
+ WRITEDIAGFI: date=     3.291667    
+0**********    pas   3160     jour 219.heure  7.0    date   3.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985842 0.122995E+01     0.948     0.820     0.947    11.434     0.952
+
+ Ls =    101.8134      tauref(700 Pa,lat=0) =   0.1803685      tau(Viking1) = 
+   0.1574863    
+ Ls =    101.8230      tauref(700 Pa,lat=0) =   0.1807783      tau(Viking1) = 
+   0.1574671    
+ WRITEDIAGFI: date=     3.333333    
+0**********    pas   3200     jour 219.heure  8.0    date   3.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985783 0.121869E+01     0.948     0.818     0.947    11.413     0.952
+
+ Ls =    101.8326      tauref(700 Pa,lat=0) =   0.1811880      tau(Viking1) = 
+   0.1574896    
+ Ls =    101.8422      tauref(700 Pa,lat=0) =   0.1815981      tau(Viking1) = 
+   0.1576085    
+ WRITEDIAGFI: date=     3.375000    
+0**********    pas   3240     jour 219.heure  9.0    date   3.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985722 0.121677E+01     0.948     0.826     0.947    11.396     0.952
+
+ Ls =    101.8519      tauref(700 Pa,lat=0) =   0.1820078      tau(Viking1) = 
+   0.1576919    
+ Ls =    101.8615      tauref(700 Pa,lat=0) =   0.1824175      tau(Viking1) = 
+   0.1577895    
+ WRITEDIAGFI: date=     3.416667    
+0**********    pas   3280     jour 219.heure 10.0    date   3.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985662 0.123578E+01     0.948     0.839     0.947    11.387     0.952
+
+ Ls =    101.8711      tauref(700 Pa,lat=0) =   0.1828275      tau(Viking1) = 
+   0.1578359    
+ Ls =    101.8807      tauref(700 Pa,lat=0) =   0.1832373      tau(Viking1) = 
+   0.1578914    
+ WRITEDIAGFI: date=     3.458333    
+0**********    pas   3320     jour 219.heure 11.0    date   3.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985600 0.126361E+01     0.948     0.839     0.946    11.386     0.952
+
+ Ls =    101.8903      tauref(700 Pa,lat=0) =   0.1836470      tau(Viking1) = 
+   0.1579685    
+ Ls =    101.8999      tauref(700 Pa,lat=0) =   0.1840570      tau(Viking1) = 
+   0.1580850    
+ WRITEDIAGFI: date=     3.500000    
+0**********    pas   3360     jour 219.heure 12.0    date   3.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985538 0.127786E+01     0.948     0.836     0.946    11.385     0.952
+
+ Ls =    101.9095      tauref(700 Pa,lat=0) =   0.1844667      tau(Viking1) = 
+   0.1582255    
+ Ls =    101.9192      tauref(700 Pa,lat=0) =   0.1848765      tau(Viking1) = 
+   0.1583841    
+ WRITEDIAGFI: date=     3.541667    
+0**********    pas   3400     jour 219.heure 13.0    date   3.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985474 0.127198E+01     0.948     0.845     0.946    11.380     0.952
+
+ Ls =    101.9288      tauref(700 Pa,lat=0) =   0.1852865      tau(Viking1) = 
+   0.1585200    
+ Ls =    101.9384      tauref(700 Pa,lat=0) =   0.1856962      tau(Viking1) = 
+   0.1585992    
+ WRITEDIAGFI: date=     3.583333    
+0**********    pas   3440     jour 219.heure 14.0    date   3.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985410 0.124889E+01     0.948     0.864     0.946    11.366     0.952
+
+ Ls =    101.9480      tauref(700 Pa,lat=0) =   0.1861060      tau(Viking1) = 
+   0.1586749    
+ Ls =    101.9576      tauref(700 Pa,lat=0) =   0.1865160      tau(Viking1) = 
+   0.1587605    
+ WRITEDIAGFI: date=     3.625000    
+0**********    pas   3480     jour 219.heure 15.0    date   3.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985348 0.122675E+01     0.947     0.866     0.946    11.348     0.952
+
+ Ls =    101.9673      tauref(700 Pa,lat=0) =   0.1869258      tau(Viking1) = 
+   0.1588273    
+ Ls =    101.9769      tauref(700 Pa,lat=0) =   0.1873355      tau(Viking1) = 
+   0.1588369    
+ WRITEDIAGFI: date=     3.666667    
+0**********    pas   3520     jour 219.heure 16.0    date   3.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985286 0.122087E+01     0.947     0.860     0.946    11.330     0.952
+
+ Ls =    101.9865      tauref(700 Pa,lat=0) =   0.1877455      tau(Viking1) = 
+   0.1588166    
+ Ls =    101.9961      tauref(700 Pa,lat=0) =   0.1881552      tau(Viking1) = 
+   0.1588081    
+ WRITEDIAGFI: date=     3.708333    
+0**********    pas   3560     jour 219.heure 17.0    date   3.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985223 0.121407E+01     0.947     0.862     0.946    11.312     0.952
+
+ Ls =    102.0057      tauref(700 Pa,lat=0) =   0.1885650      tau(Viking1) = 
+   0.1587736    
+ Ls =    102.0153      tauref(700 Pa,lat=0) =   0.1889750      tau(Viking1) = 
+   0.1587163    
+ WRITEDIAGFI: date=     3.750000    
+0**********    pas   3600     jour 219.heure 18.0    date   3.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985160 0.120708E+01     0.947     0.871     0.946    11.297     0.952
+
+ Ls =    102.0250      tauref(700 Pa,lat=0) =   0.1893847      tau(Viking1) = 
+   0.1586453    
+ Ls =    102.0346      tauref(700 Pa,lat=0) =   0.1897945      tau(Viking1) = 
+   0.1585843    
+ WRITEDIAGFI: date=     3.791667    
+0**********    pas   3640     jour 219.heure 19.0    date   3.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985094 0.119289E+01     0.947     0.880     0.946    11.287     0.952
+
+ Ls =    102.0442      tauref(700 Pa,lat=0) =   0.1902045      tau(Viking1) = 
+   0.1585058    
+ Ls =    102.0538      tauref(700 Pa,lat=0) =   0.1906142      tau(Viking1) = 
+   0.1584574    
+ WRITEDIAGFI: date=     3.833333    
+0**********    pas   3680     jour 219.heure 20.0    date   3.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.985030 0.116808E+01     0.947     0.885     0.946    11.287     0.952
+
+ Ls =    102.0634      tauref(700 Pa,lat=0) =   0.1910240      tau(Viking1) = 
+   0.1584546    
+ Ls =    102.0731      tauref(700 Pa,lat=0) =   0.1914340      tau(Viking1) = 
+   0.1585058    
+ WRITEDIAGFI: date=     3.875000    
+0**********    pas   3720     jour 219.heure 21.0    date   3.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984964 0.116049E+01     0.947     0.883     0.946    11.305     0.951
+
+ Ls =    102.0827      tauref(700 Pa,lat=0) =   0.1918437      tau(Viking1) = 
+   0.1586636    
+ Ls =    102.0923      tauref(700 Pa,lat=0) =   0.1922535      tau(Viking1) = 
+   0.1590425    
+ WRITEDIAGFI: date=     3.916667    
+0**********    pas   3760     jour 219.heure 22.0    date   3.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984900 0.117976E+01     0.947     0.885     0.946    11.341     0.951
+
+ Ls =    102.1019      tauref(700 Pa,lat=0) =   0.1926635      tau(Viking1) = 
+   0.1598581    
+ Ls =    102.1116      tauref(700 Pa,lat=0) =   0.1930732      tau(Viking1) = 
+   0.1608432    
+ WRITEDIAGFI: date=     3.958333    
+0**********    pas   3800     jour 219.heure 23.0    date   3.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984835 0.121597E+01     0.947     0.890     0.946    11.391     0.951
+
+ Ls =    102.1212      tauref(700 Pa,lat=0) =   0.1934830      tau(Viking1) = 
+   0.1614749    
+ Ls =    102.1308      tauref(700 Pa,lat=0) =   0.1938930      tau(Viking1) = 
+   0.1619355    
+ WRITEDIAGFI: date=     4.000000    
+0**********    pas   3840     jour 220.heure  0.0    date   4.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984772 0.125212E+01     0.947     0.880     0.946    11.441     0.951
+
+ LTE rad. calculations up to layer            24
+ Ls =    102.1404      tauref(700 Pa,lat=0) =   0.1942313      tau(Viking1) = 
+   0.1622375    
+ Ls =    102.1500      tauref(700 Pa,lat=0) =   0.1945658      tau(Viking1) = 
+   0.1624920    
+ WRITEDIAGFI: date=     4.041667    
+0**********    pas   3880     jour 220.heure  1.0    date   4.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984712 0.126570E+01     0.947     0.858     0.946    11.479     0.951
+
+ Ls =    102.1597      tauref(700 Pa,lat=0) =   0.1949006      tau(Viking1) = 
+   0.1626887    
+ Ls =    102.1693      tauref(700 Pa,lat=0) =   0.1952351      tau(Viking1) = 
+   0.1629287    
+ WRITEDIAGFI: date=     4.083333    
+0**********    pas   3920     jour 220.heure  2.0    date   4.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984650 0.125491E+01     0.947     0.846     0.946    11.497     0.951
+
+ Ls =    102.1789      tauref(700 Pa,lat=0) =   0.1955696      tau(Viking1) = 
+   0.1631362    
+ Ls =    102.1886      tauref(700 Pa,lat=0) =   0.1959044      tau(Viking1) = 
+   0.1633498    
+ WRITEDIAGFI: date=     4.125000    
+0**********    pas   3960     jour 220.heure  3.0    date   4.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984592 0.123334E+01     0.947     0.847     0.946    11.497     0.951
+
+ Ls =    102.1982      tauref(700 Pa,lat=0) =   0.1962389      tau(Viking1) = 
+   0.1635685    
+ Ls =    102.2078      tauref(700 Pa,lat=0) =   0.1965735      tau(Viking1) = 
+   0.1637354    
+ WRITEDIAGFI: date=     4.166667    
+0**********    pas   4000     jour 220.heure  4.0    date   4.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984532 0.121685E+01     0.947     0.849     0.946    11.486     0.951
+
+ Ls =    102.2174      tauref(700 Pa,lat=0) =   0.1969082      tau(Viking1) = 
+   0.1637943    
+ Ls =    102.2270      tauref(700 Pa,lat=0) =   0.1972428      tau(Viking1) = 
+   0.1637700    
+ WRITEDIAGFI: date=     4.208333    
+0**********    pas   4040     jour 220.heure  5.0    date   4.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984465 0.121788E+01     0.947     0.842     0.946    11.469     0.951
+
+ Ls =    102.2366      tauref(700 Pa,lat=0) =   0.1975773      tau(Viking1) = 
+   0.1636751    
+ Ls =    102.2463      tauref(700 Pa,lat=0) =   0.1979121      tau(Viking1) = 
+   0.1634974    
+ WRITEDIAGFI: date=     4.250000    
+0**********    pas   4080     jour 220.heure  6.0    date   4.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984407 0.123123E+01     0.947     0.831     0.946    11.449     0.952
+
+ Ls =    102.2559      tauref(700 Pa,lat=0) =   0.1982466      tau(Viking1) = 
+   0.1632447    
+ Ls =    102.2655      tauref(700 Pa,lat=0) =   0.1985811      tau(Viking1) = 
+   0.1629350    
+ WRITEDIAGFI: date=     4.291667    
+0**********    pas   4120     jour 220.heure  7.0    date   4.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984349 0.123690E+01     0.947     0.834     0.945    11.428     0.952
+
+ Ls =    102.2752      tauref(700 Pa,lat=0) =   0.1989159      tau(Viking1) = 
+   0.1625958    
+ Ls =    102.2848      tauref(700 Pa,lat=0) =   0.1992504      tau(Viking1) = 
+   0.1622745    
+ WRITEDIAGFI: date=     4.333333    
+0**********    pas   4160     jour 220.heure  8.0    date   4.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984289 0.123120E+01     0.946     0.846     0.945    11.404     0.952
+
+ Ls =    102.2944      tauref(700 Pa,lat=0) =   0.1995849      tau(Viking1) = 
+   0.1620158    
+ Ls =    102.3040      tauref(700 Pa,lat=0) =   0.1999197      tau(Viking1) = 
+   0.1618536    
+ WRITEDIAGFI: date=     4.375000    
+0**********    pas   4200     jour 220.heure  9.0    date   4.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984229 0.123329E+01     0.946     0.850     0.945    11.386     0.952
+
+ Ls =    102.3136      tauref(700 Pa,lat=0) =   0.2002542      tau(Viking1) = 
+   0.1616634    
+ Ls =    102.3233      tauref(700 Pa,lat=0) =   0.2005888      tau(Viking1) = 
+   0.1614891    
+ WRITEDIAGFI: date=     4.416667    
+0**********    pas   4240     jour 220.heure 10.0    date   4.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984167 0.125441E+01     0.946     0.864     0.945    11.376     0.952
+
+ Ls =    102.3329      tauref(700 Pa,lat=0) =   0.2009235      tau(Viking1) = 
+   0.1612898    
+ Ls =    102.3425      tauref(700 Pa,lat=0) =   0.2012581      tau(Viking1) = 
+   0.1611069    
+ WRITEDIAGFI: date=     4.458333    
+0**********    pas   4280     jour 220.heure 11.0    date   4.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984108 0.128303E+01     0.946     0.871     0.945    11.374     0.952
+
+ Ls =    102.3522      tauref(700 Pa,lat=0) =   0.2015926      tau(Viking1) = 
+   0.1609326    
+ Ls =    102.3618      tauref(700 Pa,lat=0) =   0.2019274      tau(Viking1) = 
+   0.1607908    
+ WRITEDIAGFI: date=     4.500000    
+0**********    pas   4320     jour 220.heure 12.0    date   4.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.984045 0.129659E+01     0.946     0.856     0.945    11.373     0.951
+
+ Ls =    102.3714      tauref(700 Pa,lat=0) =   0.2022619      tau(Viking1) = 
+   0.1606730    
+ Ls =    102.3810      tauref(700 Pa,lat=0) =   0.2025964      tau(Viking1) = 
+   0.1605603    
+ WRITEDIAGFI: date=     4.541667    
+0**********    pas   4360     jour 220.heure 13.0    date   4.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983982 0.128942E+01     0.946     0.846     0.945    11.366     0.951
+
+ Ls =    102.3907      tauref(700 Pa,lat=0) =   0.2029312      tau(Viking1) = 
+   0.1604273    
+ Ls =    102.4003      tauref(700 Pa,lat=0) =   0.2032657      tau(Viking1) = 
+   0.1602320    
+ WRITEDIAGFI: date=     4.583333    
+0**********    pas   4400     jour 220.heure 14.0    date   4.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983919 0.126696E+01     0.946     0.846     0.945    11.352     0.951
+
+ Ls =    102.4099      tauref(700 Pa,lat=0) =   0.2036003      tau(Viking1) = 
+   0.1600422    
+ Ls =    102.4195      tauref(700 Pa,lat=0) =   0.2039350      tau(Viking1) = 
+   0.1598593    
+ WRITEDIAGFI: date=     4.625000    
+0**********    pas   4440     jour 220.heure 15.0    date   4.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983855 0.124406E+01     0.946     0.854     0.945    11.333     0.951
+
+ Ls =    102.4292      tauref(700 Pa,lat=0) =   0.2042696      tau(Viking1) = 
+   0.1596348    
+ Ls =    102.4388      tauref(700 Pa,lat=0) =   0.2046041      tau(Viking1) = 
+   0.1593687    
+ WRITEDIAGFI: date=     4.666667    
+0**********    pas   4480     jour 220.heure 16.0    date   4.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983791 0.123408E+01     0.946     0.862     0.945    11.315     0.951
+
+ Ls =    102.4484      tauref(700 Pa,lat=0) =   0.2049389      tau(Viking1) = 
+   0.1590927    
+ Ls =    102.4581      tauref(700 Pa,lat=0) =   0.2052734      tau(Viking1) = 
+   0.1588182    
+ WRITEDIAGFI: date=     4.708333    
+0**********    pas   4520     jour 220.heure 17.0    date   4.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983728 0.122176E+01     0.946     0.867     0.945    11.298     0.951
+
+ Ls =    102.4677      tauref(700 Pa,lat=0) =   0.2056079      tau(Viking1) = 
+   0.1585223    
+ Ls =    102.4773      tauref(700 Pa,lat=0) =   0.2059427      tau(Viking1) = 
+   0.1582046    
+ WRITEDIAGFI: date=     4.750000    
+0**********    pas   4560     jour 220.heure 18.0    date   4.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983665 0.120963E+01     0.946     0.872     0.945    11.284     0.951
+
+ Ls =    102.4869      tauref(700 Pa,lat=0) =   0.2062772      tau(Viking1) = 
+   0.1578616    
+ Ls =    102.4966      tauref(700 Pa,lat=0) =   0.2066118      tau(Viking1) = 
+   0.1575229    
+ WRITEDIAGFI: date=     4.791667    
+0**********    pas   4600     jour 220.heure 19.0    date   4.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983600 0.119033E+01     0.946     0.878     0.945    11.275     0.951
+
+ Ls =    102.5062      tauref(700 Pa,lat=0) =   0.2069465      tau(Viking1) = 
+   0.1571862    
+ Ls =    102.5158      tauref(700 Pa,lat=0) =   0.2072811      tau(Viking1) = 
+   0.1568838    
+ WRITEDIAGFI: date=     4.833333    
+0**********    pas   4640     jour 220.heure 20.0    date   4.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983534 0.115934E+01     0.946     0.882     0.945    11.277     0.951
+
+ Ls =    102.5255      tauref(700 Pa,lat=0) =   0.2076156      tau(Viking1) = 
+   0.1566412    
+ Ls =    102.5351      tauref(700 Pa,lat=0) =   0.2079504      tau(Viking1) = 
+   0.1564518    
+ WRITEDIAGFI: date=     4.875000    
+0**********    pas   4680     jour 220.heure 21.0    date   4.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983469 0.114541E+01     0.946     0.882     0.945    11.295     0.951
+
+ Ls =    102.5447      tauref(700 Pa,lat=0) =   0.2082849      tau(Viking1) = 
+   0.1563561    
+ Ls =    102.5543      tauref(700 Pa,lat=0) =   0.2086194      tau(Viking1) = 
+   0.1564896    
+ WRITEDIAGFI: date=     4.916667    
+0**********    pas   4720     jour 220.heure 22.0    date   4.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983405 0.116007E+01     0.946     0.882     0.945    11.333     0.950
+
+ Ls =    102.5639      tauref(700 Pa,lat=0) =   0.2089542      tau(Viking1) = 
+   0.1570649    
+ Ls =    102.5736      tauref(700 Pa,lat=0) =   0.2092887      tau(Viking1) = 
+   0.1577958    
+ WRITEDIAGFI: date=     4.958333    
+0**********    pas   4760     jour 220.heure 23.0    date   4.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983342 0.119281E+01     0.946     0.882     0.945    11.385     0.950
+
+ Ls =    102.5832      tauref(700 Pa,lat=0) =   0.2096232      tau(Viking1) = 
+   0.1581572    
+ Ls =    102.5928      tauref(700 Pa,lat=0) =   0.2099580      tau(Viking1) = 
+   0.1583529    
+ WRITEDIAGFI: date=     5.000000    
+0**********    pas   4800     jour 221.heure  0.0    date   5.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983278 0.122425E+01     0.946     0.874     0.945    11.438     0.950
+
+ LTE rad. calculations up to layer            24
+ Ls =    102.6025      tauref(700 Pa,lat=0) =   0.2095421      tau(Viking1) = 
+   0.1585817    
+ Ls =    102.6121      tauref(700 Pa,lat=0) =   0.2090867      tau(Viking1) = 
+   0.1587702    
+ WRITEDIAGFI: date=     5.041667    
+0**********    pas   4840     jour 221.heure  1.0    date   5.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983219 0.123408E+01     0.946     0.864     0.945    11.479     0.950
+
+ Ls =    102.6218      tauref(700 Pa,lat=0) =   0.2086311      tau(Viking1) = 
+   0.1589089    
+ Ls =    102.6314      tauref(700 Pa,lat=0) =   0.2081757      tau(Viking1) = 
+   0.1590687    
+ WRITEDIAGFI: date=     5.083333    
+0**********    pas   4880     jour 221.heure  2.0    date   5.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983155 0.122186E+01     0.946     0.866     0.945    11.501     0.950
+
+ Ls =    102.6410      tauref(700 Pa,lat=0) =   0.2077204      tau(Viking1) = 
+   0.1592141    
+ Ls =    102.6507      tauref(700 Pa,lat=0) =   0.2072648      tau(Viking1) = 
+   0.1593634    
+ WRITEDIAGFI: date=     5.125000    
+0**********    pas   4920     jour 221.heure  3.0    date   5.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983097 0.120101E+01     0.946     0.873     0.945    11.505     0.950
+
+ Ls =    102.6603      tauref(700 Pa,lat=0) =   0.2068095      tau(Viking1) = 
+   0.1595060    
+ Ls =    102.6699      tauref(700 Pa,lat=0) =   0.2063541      tau(Viking1) = 
+   0.1595969    
+ WRITEDIAGFI: date=     5.166667    
+0**********    pas   4960     jour 221.heure  4.0    date   5.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.983040 0.118686E+01     0.945     0.879     0.945    11.496     0.950
+
+ Ls =    102.6795      tauref(700 Pa,lat=0) =   0.2058985      tau(Viking1) = 
+   0.1596120    
+ Ls =    102.6892      tauref(700 Pa,lat=0) =   0.2054432      tau(Viking1) = 
+   0.1595294    
+ WRITEDIAGFI: date=     5.208333    
+0**********    pas   5000     jour 221.heure  5.0    date   5.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982979 0.119209E+01     0.945     0.880     0.945    11.480     0.951
+
+ Ls =    102.6988      tauref(700 Pa,lat=0) =   0.2049878      tau(Viking1) = 
+   0.1593817    
+ Ls =    102.7084      tauref(700 Pa,lat=0) =   0.2045322      tau(Viking1) = 
+   0.1591578    
+ WRITEDIAGFI: date=     5.250000    
+0**********    pas   5040     jour 221.heure  6.0    date   5.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982922 0.120911E+01     0.945     0.877     0.945    11.461     0.951
+
+ Ls =    102.7180      tauref(700 Pa,lat=0) =   0.2040769      tau(Viking1) = 
+   0.1588660    
+ Ls =    102.7277      tauref(700 Pa,lat=0) =   0.2036215      tau(Viking1) = 
+   0.1585040    
+ WRITEDIAGFI: date=     5.291667    
+0**********    pas   5080     jour 221.heure  7.0    date   5.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982863 0.121757E+01     0.945     0.877     0.944    11.440     0.951
+
+ Ls =    102.7373      tauref(700 Pa,lat=0) =   0.2031659      tau(Viking1) = 
+   0.1581252    
+ Ls =    102.7469      tauref(700 Pa,lat=0) =   0.2027106      tau(Viking1) = 
+   0.1577676    
+ WRITEDIAGFI: date=     5.333333    
+0**********    pas   5120     jour 221.heure  8.0    date   5.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982804 0.121427E+01     0.945     0.879     0.944    11.416     0.951
+
+ Ls =    102.7566      tauref(700 Pa,lat=0) =   0.2022552      tau(Viking1) = 
+   0.1574609    
+ Ls =    102.7662      tauref(700 Pa,lat=0) =   0.2017996      tau(Viking1) = 
+   0.1572487    
+ WRITEDIAGFI: date=     5.375000    
+0**********    pas   5160     jour 221.heure  9.0    date   5.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982743 0.122057E+01     0.945     0.883     0.944    11.396     0.951
+
+ Ls =    102.7758      tauref(700 Pa,lat=0) =   0.2013443      tau(Viking1) = 
+   0.1570061    
+ Ls =    102.7855      tauref(700 Pa,lat=0) =   0.2008889      tau(Viking1) = 
+   0.1567947    
+ WRITEDIAGFI: date=     5.416667    
+0**********    pas   5200     jour 221.heure 10.0    date   5.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982682 0.124671E+01     0.945     0.884     0.944    11.384     0.951
+
+ Ls =    102.7951      tauref(700 Pa,lat=0) =   0.2004333      tau(Viking1) = 
+   0.1565510    
+ Ls =    102.8048      tauref(700 Pa,lat=0) =   0.1999780      tau(Viking1) = 
+   0.1563300    
+ WRITEDIAGFI: date=     5.458333    
+0**********    pas   5240     jour 221.heure 11.0    date   5.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982625 0.127760E+01     0.945     0.886     0.944    11.379     0.951
+
+ Ls =    102.8144      tauref(700 Pa,lat=0) =   0.1995226      tau(Viking1) = 
+   0.1561067    
+ Ls =    102.8240      tauref(700 Pa,lat=0) =   0.1990670      tau(Viking1) = 
+   0.1559188    
+ WRITEDIAGFI: date=     5.500000    
+0**********    pas   5280     jour 221.heure 12.0    date   5.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982559 0.129206E+01     0.945     0.879     0.944    11.376     0.951
+
+ Ls =    102.8337      tauref(700 Pa,lat=0) =   0.1986117      tau(Viking1) = 
+   0.1557526    
+ Ls =    102.8433      tauref(700 Pa,lat=0) =   0.1981563      tau(Viking1) = 
+   0.1555917    
+ WRITEDIAGFI: date=     5.541667    
+0**********    pas   5320     jour 221.heure 13.0    date   5.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982494 0.128576E+01     0.944     0.857     0.944    11.369     0.950
+
+ Ls =    102.8529      tauref(700 Pa,lat=0) =   0.1977007      tau(Viking1) = 
+   0.1553981    
+ Ls =    102.8626      tauref(700 Pa,lat=0) =   0.1972454      tau(Viking1) = 
+   0.1551480    
+ WRITEDIAGFI: date=     5.583333    
+0**********    pas   5360     jour 221.heure 14.0    date   5.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982433 0.126254E+01     0.944     0.845     0.944    11.357     0.950
+
+ Ls =    102.8722      tauref(700 Pa,lat=0) =   0.1967900      tau(Viking1) = 
+   0.1549007    
+ Ls =    102.8819      tauref(700 Pa,lat=0) =   0.1963344      tau(Viking1) = 
+   0.1546516    
+ WRITEDIAGFI: date=     5.625000    
+0**********    pas   5400     jour 221.heure 15.0    date   5.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982371 0.123873E+01     0.944     0.843     0.944    11.341     0.950
+
+ Ls =    102.8915      tauref(700 Pa,lat=0) =   0.1958791      tau(Viking1) = 
+   0.1543740    
+ Ls =    102.9011      tauref(700 Pa,lat=0) =   0.1954237      tau(Viking1) = 
+   0.1540445    
+ WRITEDIAGFI: date=     5.666667    
+0**********    pas   5440     jour 221.heure 16.0    date   5.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982307 0.122882E+01     0.944     0.847     0.944    11.325     0.950
+
+ Ls =    102.9108      tauref(700 Pa,lat=0) =   0.1949681      tau(Viking1) = 
+   0.1537083    
+ Ls =    102.9204      tauref(700 Pa,lat=0) =   0.1945128      tau(Viking1) = 
+   0.1533814    
+ WRITEDIAGFI: date=     5.708333    
+0**********    pas   5480     jour 221.heure 17.0    date   5.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982243 0.121770E+01     0.944     0.858     0.944    11.310     0.950
+
+ Ls =    102.9300      tauref(700 Pa,lat=0) =   0.1940574      tau(Viking1) = 
+   0.1530301    
+ Ls =    102.9397      tauref(700 Pa,lat=0) =   0.1936018      tau(Viking1) = 
+   0.1526722    
+ WRITEDIAGFI: date=     5.750000    
+0**********    pas   5520     jour 221.heure 18.0    date   5.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982178 0.120539E+01     0.944     0.875     0.944    11.296     0.950
+
+ Ls =    102.9493      tauref(700 Pa,lat=0) =   0.1931465      tau(Viking1) = 
+   0.1522948    
+ Ls =    102.9589      tauref(700 Pa,lat=0) =   0.1926911      tau(Viking1) = 
+   0.1519265    
+ WRITEDIAGFI: date=     5.791667    
+0**********    pas   5560     jour 221.heure 19.0    date   5.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982115 0.118404E+01     0.944     0.892     0.944    11.286     0.950
+
+ Ls =    102.9686      tauref(700 Pa,lat=0) =   0.1922355      tau(Viking1) = 
+   0.1515731    
+ Ls =    102.9782      tauref(700 Pa,lat=0) =   0.1917802      tau(Viking1) = 
+   0.1512509    
+ WRITEDIAGFI: date=     5.833333    
+0**********    pas   5600     jour 221.heure 20.0    date   5.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.982049 0.115126E+01     0.944     0.899     0.944    11.287     0.950
+
+ Ls =    102.9878      tauref(700 Pa,lat=0) =   0.1913249      tau(Viking1) = 
+   0.1509673    
+ Ls =    102.9975      tauref(700 Pa,lat=0) =   0.1908692      tau(Viking1) = 
+   0.1507262    
+ WRITEDIAGFI: date=     5.875000    
+0**********    pas   5640     jour 221.heure 21.0    date   5.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981985 0.113504E+01     0.944     0.899     0.944    11.306     0.949
+
+ Ls =    103.0071      tauref(700 Pa,lat=0) =   0.1904139      tau(Viking1) = 
+   0.1505843    
+ Ls =    103.0168      tauref(700 Pa,lat=0) =   0.1899586      tau(Viking1) = 
+   0.1506608    
+ WRITEDIAGFI: date=     5.916667    
+0**********    pas   5680     jour 221.heure 22.0    date   5.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981919 0.114791E+01     0.944     0.904     0.944    11.345     0.949
+
+ Ls =    103.0264      tauref(700 Pa,lat=0) =   0.1895029      tau(Viking1) = 
+   0.1511442    
+ Ls =    103.0360      tauref(700 Pa,lat=0) =   0.1890476      tau(Viking1) = 
+   0.1517833    
+ WRITEDIAGFI: date=     5.958333    
+0**********    pas   5720     jour 221.heure 23.0    date   5.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981854 0.118005E+01     0.944     0.905     0.944    11.398     0.949
+
+ Ls =    103.0457      tauref(700 Pa,lat=0) =   0.1885923      tau(Viking1) = 
+   0.1520770    
+ Ls =    103.0553      tauref(700 Pa,lat=0) =   0.1881366      tau(Viking1) = 
+   0.1522001    
+ WRITEDIAGFI: date=     6.000000    
+0**********    pas   5760     jour 222.heure  0.0    date   6.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981796 0.121108E+01     0.944     0.892     0.944    11.452     0.949
+
+ LTE rad. calculations up to layer            24
+ Ls =    103.0649      tauref(700 Pa,lat=0) =   0.1878785      tau(Viking1) = 
+   0.1525291    
+ Ls =    103.0746      tauref(700 Pa,lat=0) =   0.1876306      tau(Viking1) = 
+   0.1528435    
+ WRITEDIAGFI: date=     6.041667    
+0**********    pas   5800     jour 222.heure  1.0    date   6.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981736 0.122072E+01     0.944     0.873     0.944    11.494     0.949
+
+ Ls =    103.0842      tauref(700 Pa,lat=0) =   0.1873826      tau(Viking1) = 
+   0.1530837    
+ Ls =    103.0939      tauref(700 Pa,lat=0) =   0.1871348      tau(Viking1) = 
+   0.1533591    
+ WRITEDIAGFI: date=     6.083333    
+0**********    pas   5840     jour 222.heure  2.0    date   6.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981674 0.120736E+01     0.944     0.855     0.944    11.516     0.949
+
+ Ls =    103.1035      tauref(700 Pa,lat=0) =   0.1868870      tau(Viking1) = 
+   0.1536333    
+ Ls =    103.1131      tauref(700 Pa,lat=0) =   0.1866390      tau(Viking1) = 
+   0.1539129    
+ WRITEDIAGFI: date=     6.125000    
+0**********    pas   5880     jour 222.heure  3.0    date   6.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981612 0.118554E+01     0.944     0.842     0.944    11.519     0.949
+
+ Ls =    103.1228      tauref(700 Pa,lat=0) =   0.1863912      tau(Viking1) = 
+   0.1541928    
+ Ls =    103.1324      tauref(700 Pa,lat=0) =   0.1861434      tau(Viking1) = 
+   0.1544403    
+ WRITEDIAGFI: date=     6.166667    
+0**********    pas   5920     jour 222.heure  4.0    date   6.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981554 0.116894E+01     0.944     0.843     0.944    11.510     0.949
+
+ Ls =    103.1421      tauref(700 Pa,lat=0) =   0.1858954      tau(Viking1) = 
+   0.1545930    
+ Ls =    103.1517      tauref(700 Pa,lat=0) =   0.1856476      tau(Viking1) = 
+   0.1546488    
+ WRITEDIAGFI: date=     6.208333    
+0**********    pas   5960     jour 222.heure  5.0    date   6.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981493 0.117277E+01     0.944     0.845     0.944    11.494     0.949
+
+ Ls =    103.1613      tauref(700 Pa,lat=0) =   0.1853998      tau(Viking1) = 
+   0.1546241    
+ Ls =    103.1710      tauref(700 Pa,lat=0) =   0.1851518      tau(Viking1) = 
+   0.1545311    
+ WRITEDIAGFI: date=     6.250000    
+0**********    pas   6000     jour 222.heure  6.0    date   6.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981436 0.118933E+01     0.944     0.845     0.944    11.474     0.950
+
+ Ls =    103.1806      tauref(700 Pa,lat=0) =   0.1849040      tau(Viking1) = 
+   0.1543523    
+ Ls =    103.1902      tauref(700 Pa,lat=0) =   0.1846562      tau(Viking1) = 
+   0.1541526    
+ WRITEDIAGFI: date=     6.291667    
+0**********    pas   6040     jour 222.heure  7.0    date   6.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981379 0.119621E+01     0.944     0.847     0.943    11.451     0.950
+
+ Ls =    103.1999      tauref(700 Pa,lat=0) =   0.1844082      tau(Viking1) = 
+   0.1539142    
+ Ls =    103.2095      tauref(700 Pa,lat=0) =   0.1841604      tau(Viking1) = 
+   0.1536977    
+ WRITEDIAGFI: date=     6.333333    
+0**********    pas   6080     jour 222.heure  8.0    date   6.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981320 0.119206E+01     0.944     0.854     0.943    11.426     0.950
+
+ Ls =    103.2192      tauref(700 Pa,lat=0) =   0.1839126      tau(Viking1) = 
+   0.1535333    
+ Ls =    103.2288      tauref(700 Pa,lat=0) =   0.1836646      tau(Viking1) = 
+   0.1534714    
+ WRITEDIAGFI: date=     6.375000    
+0**********    pas   6120     jour 222.heure  9.0    date   6.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981258 0.119834E+01     0.944     0.858     0.943    11.405     0.950
+
+ Ls =    103.2385      tauref(700 Pa,lat=0) =   0.1834168      tau(Viking1) = 
+   0.1533897    
+ Ls =    103.2481      tauref(700 Pa,lat=0) =   0.1831690      tau(Viking1) = 
+   0.1533269    
+ WRITEDIAGFI: date=     6.416667    
+0**********    pas   6160     jour 222.heure 10.0    date   6.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981198 0.122535E+01     0.943     0.864     0.943    11.393     0.950
+
+ Ls =    103.2578      tauref(700 Pa,lat=0) =   0.1829210      tau(Viking1) = 
+   0.1532336    
+ Ls =    103.2674      tauref(700 Pa,lat=0) =   0.1826732      tau(Viking1) = 
+   0.1531510    
+ WRITEDIAGFI: date=     6.458333    
+0**********    pas   6200     jour 222.heure 11.0    date   6.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981138 0.125932E+01     0.943     0.870     0.943    11.388     0.949
+
+ Ls =    103.2770      tauref(700 Pa,lat=0) =   0.1824253      tau(Viking1) = 
+   0.1530671    
+ Ls =    103.2867      tauref(700 Pa,lat=0) =   0.1821773      tau(Viking1) = 
+   0.1530171    
+ WRITEDIAGFI: date=     6.500000    
+0**********    pas   6240     jour 222.heure 12.0    date   6.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981075 0.127473E+01     0.943     0.863     0.943    11.383     0.949
+
+ Ls =    103.2963      tauref(700 Pa,lat=0) =   0.1819296      tau(Viking1) = 
+   0.1529910    
+ Ls =    103.3060      tauref(700 Pa,lat=0) =   0.1816817      tau(Viking1) = 
+   0.1529631    
+ WRITEDIAGFI: date=     6.541667    
+0**********    pas   6280     jour 222.heure 13.0    date   6.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.981012 0.126946E+01     0.943     0.858     0.943    11.374     0.949
+
+ Ls =    103.3157      tauref(700 Pa,lat=0) =   0.1814338      tau(Viking1) = 
+   0.1529089    
+ Ls =    103.3253      tauref(700 Pa,lat=0) =   0.1811859      tau(Viking1) = 
+   0.1528040    
+ WRITEDIAGFI: date=     6.583333    
+0**********    pas   6320     jour 222.heure 14.0    date   6.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980950 0.124710E+01     0.943     0.861     0.943    11.357     0.949
+
+ Ls =    103.3349      tauref(700 Pa,lat=0) =   0.1809381      tau(Viking1) = 
+   0.1526935    
+ Ls =    103.3446      tauref(700 Pa,lat=0) =   0.1806901      tau(Viking1) = 
+   0.1525835    
+ WRITEDIAGFI: date=     6.625000    
+0**********    pas   6360     jour 222.heure 15.0    date   6.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980884 0.122567E+01     0.943     0.866     0.943    11.338     0.949
+
+ Ls =    103.3542      tauref(700 Pa,lat=0) =   0.1804423      tau(Viking1) = 
+   0.1524667    
+ Ls =    103.3638      tauref(700 Pa,lat=0) =   0.1801945      tau(Viking1) = 
+   0.1523059    
+ WRITEDIAGFI: date=     6.666667    
+0**********    pas   6400     jour 222.heure 16.0    date   6.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980823 0.121900E+01     0.943     0.874     0.943    11.319     0.949
+
+ Ls =    103.3735      tauref(700 Pa,lat=0) =   0.1799465      tau(Viking1) = 
+   0.1521448    
+ Ls =    103.3831      tauref(700 Pa,lat=0) =   0.1796987      tau(Viking1) = 
+   0.1519964    
+ WRITEDIAGFI: date=     6.708333    
+0**********    pas   6440     jour 222.heure 17.0    date   6.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980759 0.121082E+01     0.943     0.882     0.943    11.302     0.949
+
+ Ls =    103.3927      tauref(700 Pa,lat=0) =   0.1794509      tau(Viking1) = 
+   0.1518145    
+ Ls =    103.4024      tauref(700 Pa,lat=0) =   0.1792029      tau(Viking1) = 
+   0.1516118    
+ WRITEDIAGFI: date=     6.750000    
+0**********    pas   6480     jour 222.heure 18.0    date   6.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980695 0.119998E+01     0.943     0.887     0.943    11.288     0.949
+
+ Ls =    103.4120      tauref(700 Pa,lat=0) =   0.1789551      tau(Viking1) = 
+   0.1513862    
+ Ls =    103.4217      tauref(700 Pa,lat=0) =   0.1787073      tau(Viking1) = 
+   0.1511565    
+ WRITEDIAGFI: date=     6.791667    
+0**********    pas   6520     jour 222.heure 19.0    date   6.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980630 0.118027E+01     0.943     0.887     0.943    11.279     0.949
+
+ Ls =    103.4314      tauref(700 Pa,lat=0) =   0.1784593      tau(Viking1) = 
+   0.1509176    
+ Ls =    103.4410      tauref(700 Pa,lat=0) =   0.1782115      tau(Viking1) = 
+   0.1506954    
+ WRITEDIAGFI: date=     6.833333    
+0**********    pas   6560     jour 222.heure 20.0    date   6.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980565 0.114897E+01     0.943     0.882     0.943    11.280     0.949
+
+ Ls =    103.4506      tauref(700 Pa,lat=0) =   0.1779637      tau(Viking1) = 
+   0.1505234    
+ Ls =    103.4603      tauref(700 Pa,lat=0) =   0.1777157      tau(Viking1) = 
+   0.1504244    
+ WRITEDIAGFI: date=     6.875000    
+0**********    pas   6600     jour 222.heure 21.0    date   6.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980502 0.113458E+01     0.943     0.878     0.943    11.298     0.948
+
+ Ls =    103.4699      tauref(700 Pa,lat=0) =   0.1774679      tau(Viking1) = 
+   0.1504178    
+ Ls =    103.4796      tauref(700 Pa,lat=0) =   0.1772200      tau(Viking1) = 
+   0.1506303    
+ WRITEDIAGFI: date=     6.916667    
+0**********    pas   6640     jour 222.heure 22.0    date   6.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980436 0.114972E+01     0.943     0.877     0.943    11.335     0.948
+
+ Ls =    103.4892      tauref(700 Pa,lat=0) =   0.1769720      tau(Viking1) = 
+   0.1512498    
+ Ls =    103.4989      tauref(700 Pa,lat=0) =   0.1767242      tau(Viking1) = 
+   0.1520234    
+ WRITEDIAGFI: date=     6.958333    
+0**********    pas   6680     jour 222.heure 23.0    date   6.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980373 0.118414E+01     0.943     0.873     0.943    11.387     0.948
+
+ Ls =    103.5085      tauref(700 Pa,lat=0) =   0.1764764      tau(Viking1) = 
+   0.1524595    
+ Ls =    103.5182      tauref(700 Pa,lat=0) =   0.1762284      tau(Viking1) = 
+   0.1527202    
+ WRITEDIAGFI: date=     7.000000    
+0**********    pas   6720     jour 223.heure  0.0    date   7.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980310 0.121655E+01     0.943     0.863     0.943    11.442     0.947
+
+ LTE rad. calculations up to layer            24
+ Ls =    103.5278      tauref(700 Pa,lat=0) =   0.1761024      tau(Viking1) = 
+   0.1529917    
+ Ls =    103.5374      tauref(700 Pa,lat=0) =   0.1759827      tau(Viking1) = 
+   0.1532329    
+ WRITEDIAGFI: date=     7.041667    
+0**********    pas   6760     jour 223.heure  1.0    date   7.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980251 0.122709E+01     0.943     0.851     0.943    11.485     0.947
+
+ Ls =    103.5471      tauref(700 Pa,lat=0) =   0.1758629      tau(Viking1) = 
+   0.1534221    
+ Ls =    103.5567      tauref(700 Pa,lat=0) =   0.1757432      tau(Viking1) = 
+   0.1536299    
+ WRITEDIAGFI: date=     7.083333    
+0**********    pas   6800     jour 223.heure  2.0    date   7.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980188 0.121392E+01     0.943     0.843     0.943    11.507     0.947
+
+ Ls =    103.5664      tauref(700 Pa,lat=0) =   0.1756236      tau(Viking1) = 
+   0.1538313    
+ Ls =    103.5760      tauref(700 Pa,lat=0) =   0.1755038      tau(Viking1) = 
+   0.1540457    
+ WRITEDIAGFI: date=     7.125000    
+0**********    pas   6840     jour 223.heure  3.0    date   7.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980129 0.119015E+01     0.943     0.841     0.943    11.511     0.948
+
+ Ls =    103.5857      tauref(700 Pa,lat=0) =   0.1753841      tau(Viking1) = 
+   0.1542500    
+ Ls =    103.5954      tauref(700 Pa,lat=0) =   0.1752644      tau(Viking1) = 
+   0.1544220    
+ WRITEDIAGFI: date=     7.166667    
+0**********    pas   6880     jour 223.heure  4.0    date   7.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980070 0.117095E+01     0.943     0.845     0.943    11.501     0.948
+
+ Ls =    103.6050      tauref(700 Pa,lat=0) =   0.1751447      tau(Viking1) = 
+   0.1545075    
+ Ls =    103.6146      tauref(700 Pa,lat=0) =   0.1750250      tau(Viking1) = 
+   0.1545032    
+ WRITEDIAGFI: date=     7.208333    
+0**********    pas   6920     jour 223.heure  5.0    date   7.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.980010 0.117181E+01     0.943     0.851     0.943    11.485     0.948
+
+ Ls =    103.6243      tauref(700 Pa,lat=0) =   0.1749053      tau(Viking1) = 
+   0.1544138    
+ Ls =    103.6339      tauref(700 Pa,lat=0) =   0.1747855      tau(Viking1) = 
+   0.1542601    
+ WRITEDIAGFI: date=     7.250000    
+0**********    pas   6960     jour 223.heure  6.0    date   7.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979952 0.118429E+01     0.942     0.853     0.943    11.465     0.948
+
+ Ls =    103.6436      tauref(700 Pa,lat=0) =   0.1746658      tau(Viking1) = 
+   0.1540727    
+ Ls =    103.6532      tauref(700 Pa,lat=0) =   0.1745462      tau(Viking1) = 
+   0.1538371    
+ WRITEDIAGFI: date=     7.291667    
+0**********    pas   7000     jour 223.heure  7.0    date   7.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979895 0.118821E+01     0.942     0.851     0.942    11.441     0.948
+
+ Ls =    103.6629      tauref(700 Pa,lat=0) =   0.1744264      tau(Viking1) = 
+   0.1535694    
+ Ls =    103.6725      tauref(700 Pa,lat=0) =   0.1743067      tau(Viking1) = 
+   0.1533279    
+ WRITEDIAGFI: date=     7.333333    
+0**********    pas   7040     jour 223.heure  8.0    date   7.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979836 0.118187E+01     0.942     0.851     0.942    11.413     0.948
+
+ Ls =    103.6822      tauref(700 Pa,lat=0) =   0.1741870      tau(Viking1) = 
+   0.1531579    
+ Ls =    103.6918      tauref(700 Pa,lat=0) =   0.1740672      tau(Viking1) = 
+   0.1530754    
+ WRITEDIAGFI: date=     7.375000    
+0**********    pas   7080     jour 223.heure  9.0    date   7.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979775 0.118649E+01     0.942     0.850     0.942    11.388     0.948
+
+ Ls =    103.7015      tauref(700 Pa,lat=0) =   0.1739476      tau(Viking1) = 
+   0.1529592    
+ Ls =    103.7111      tauref(700 Pa,lat=0) =   0.1738279      tau(Viking1) = 
+   0.1528374    
+ WRITEDIAGFI: date=     7.416667    
+0**********    pas   7120     jour 223.heure 10.0    date   7.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979715 0.121241E+01     0.942     0.862     0.942    11.371     0.948
+
+ Ls =    103.7208      tauref(700 Pa,lat=0) =   0.1737081      tau(Viking1) = 
+   0.1526754    
+ Ls =    103.7304      tauref(700 Pa,lat=0) =   0.1735884      tau(Viking1) = 
+   0.1525249    
+ WRITEDIAGFI: date=     7.458333    
+0**********    pas   7160     jour 223.heure 11.0    date   7.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979654 0.124468E+01     0.942     0.877     0.942    11.361     0.948
+
+ Ls =    103.7401      tauref(700 Pa,lat=0) =   0.1734687      tau(Viking1) = 
+   0.1523734    
+ Ls =    103.7497      tauref(700 Pa,lat=0) =   0.1733490      tau(Viking1) = 
+   0.1522530    
+ WRITEDIAGFI: date=     7.500000    
+0**********    pas   7200     jour 223.heure 12.0    date   7.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979592 0.125997E+01     0.942     0.882     0.942    11.354     0.948
+
+ Ls =    103.7594      tauref(700 Pa,lat=0) =   0.1732293      tau(Viking1) = 
+   0.1521653    
+ Ls =    103.7691      tauref(700 Pa,lat=0) =   0.1731096      tau(Viking1) = 
+   0.1520813    
+ WRITEDIAGFI: date=     7.541667    
+0**********    pas   7240     jour 223.heure 13.0    date   7.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979529 0.125590E+01     0.942     0.870     0.942    11.344     0.948
+
+ Ls =    103.7787      tauref(700 Pa,lat=0) =   0.1729898      tau(Viking1) = 
+   0.1519744    
+ Ls =    103.7884      tauref(700 Pa,lat=0) =   0.1728702      tau(Viking1) = 
+   0.1518216    
+ WRITEDIAGFI: date=     7.583333    
+0**********    pas   7280     jour 223.heure 14.0    date   7.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979466 0.123460E+01     0.942     0.854     0.942    11.329     0.948
+
+ Ls =    103.7980      tauref(700 Pa,lat=0) =   0.1727505      tau(Viking1) = 
+   0.1516834    
+ Ls =    103.8077      tauref(700 Pa,lat=0) =   0.1726307      tau(Viking1) = 
+   0.1515649    
+ WRITEDIAGFI: date=     7.625000    
+0**********    pas   7320     jour 223.heure 15.0    date   7.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979401 0.121395E+01     0.941     0.848     0.942    11.313     0.948
+
+ Ls =    103.8173      tauref(700 Pa,lat=0) =   0.1725110      tau(Viking1) = 
+   0.1514189    
+ Ls =    103.8270      tauref(700 Pa,lat=0) =   0.1723913      tau(Viking1) = 
+   0.1512299    
+ WRITEDIAGFI: date=     7.666667    
+0**********    pas   7360     jour 223.heure 16.0    date   7.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979339 0.120928E+01     0.941     0.849     0.942    11.299     0.948
+
+ Ls =    103.8366      tauref(700 Pa,lat=0) =   0.1722716      tau(Viking1) = 
+   0.1510346    
+ Ls =    103.8463      tauref(700 Pa,lat=0) =   0.1721519      tau(Viking1) = 
+   0.1508396    
+ WRITEDIAGFI: date=     7.708333    
+0**********    pas   7400     jour 223.heure 17.0    date   7.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979278 0.120369E+01     0.941     0.852     0.942    11.285     0.948
+
+ Ls =    103.8559      tauref(700 Pa,lat=0) =   0.1720322      tau(Viking1) = 
+   0.1506192    
+ Ls =    103.8656      tauref(700 Pa,lat=0) =   0.1719124      tau(Viking1) = 
+   0.1503842    
+ WRITEDIAGFI: date=     7.750000    
+0**********    pas   7440     jour 223.heure 18.0    date   7.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979217 0.119737E+01     0.941     0.858     0.942    11.273     0.948
+
+ Ls =    103.8752      tauref(700 Pa,lat=0) =   0.1717928      tau(Viking1) = 
+   0.1501039    
+ Ls =    103.8849      tauref(700 Pa,lat=0) =   0.1716731      tau(Viking1) = 
+   0.1498487    
+ WRITEDIAGFI: date=     7.791667    
+0**********    pas   7480     jour 223.heure 19.0    date   7.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979150 0.118142E+01     0.941     0.864     0.942    11.265     0.948
+
+ Ls =    103.8946      tauref(700 Pa,lat=0) =   0.1715533      tau(Viking1) = 
+   0.1495590    
+ Ls =    103.9042      tauref(700 Pa,lat=0) =   0.1714336      tau(Viking1) = 
+   0.1493011    
+ WRITEDIAGFI: date=     7.833333    
+0**********    pas   7520     jour 223.heure 20.0    date   7.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979083 0.115192E+01     0.941     0.863     0.942    11.266     0.947
+
+ Ls =    103.9138      tauref(700 Pa,lat=0) =   0.1713139      tau(Viking1) = 
+   0.1490952    
+ Ls =    103.9235      tauref(700 Pa,lat=0) =   0.1711942      tau(Viking1) = 
+   0.1489431    
+ WRITEDIAGFI: date=     7.875000    
+0**********    pas   7560     jour 223.heure 21.0    date   7.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.979021 0.114009E+01     0.941     0.855     0.942    11.283     0.947
+
+ Ls =    103.9332      tauref(700 Pa,lat=0) =   0.1710745      tau(Viking1) = 
+   0.1488830    
+ Ls =    103.9428      tauref(700 Pa,lat=0) =   0.1709548      tau(Viking1) = 
+   0.1490313    
+ WRITEDIAGFI: date=     7.916667    
+0**********    pas   7600     jour 223.heure 22.0    date   7.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978955 0.115725E+01     0.941     0.850     0.942    11.321     0.947
+
+ Ls =    103.9525      tauref(700 Pa,lat=0) =   0.1708350      tau(Viking1) = 
+   0.1495707    
+ Ls =    103.9621      tauref(700 Pa,lat=0) =   0.1707153      tau(Viking1) = 
+   0.1502496    
+ WRITEDIAGFI: date=     7.958333    
+0**********    pas   7640     jour 223.heure 23.0    date   7.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978891 0.119159E+01     0.941     0.849     0.942    11.374     0.946
+
+ Ls =    103.9718      tauref(700 Pa,lat=0) =   0.1705957      tau(Viking1) = 
+   0.1505920    
+ Ls =    103.9814      tauref(700 Pa,lat=0) =   0.1704759      tau(Viking1) = 
+   0.1507598    
+ WRITEDIAGFI: date=     8.000000    
+0**********    pas   7680     jour 224.heure  0.0    date   8.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978830 0.122334E+01     0.941     0.854     0.942    11.430     0.946
+
+ LTE rad. calculations up to layer            24
+ Ls =    103.9911      tauref(700 Pa,lat=0) =   0.1702597      tau(Viking1) = 
+   0.1509475    
+ Ls =    104.0007      tauref(700 Pa,lat=0) =   0.1700384      tau(Viking1) = 
+   0.1511065    
+ WRITEDIAGFI: date=     8.041667    
+0**********    pas   7720     jour 224.heure  1.0    date   8.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978770 0.123424E+01     0.941     0.864     0.942    11.473     0.946
+
+ Ls =    104.0104      tauref(700 Pa,lat=0) =   0.1698169      tau(Viking1) = 
+   0.1511968    
+ Ls =    104.0200      tauref(700 Pa,lat=0) =   0.1695956      tau(Viking1) = 
+   0.1513452    
+ WRITEDIAGFI: date=     8.083333    
+0**********    pas   7760     jour 224.heure  2.0    date   8.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978709 0.122189E+01     0.941     0.869     0.942    11.496     0.946
+
+ Ls =    104.0297      tauref(700 Pa,lat=0) =   0.1693743      tau(Viking1) = 
+   0.1514858    
+ Ls =    104.0394      tauref(700 Pa,lat=0) =   0.1691529      tau(Viking1) = 
+   0.1516390    
+ WRITEDIAGFI: date=     8.125000    
+0**********    pas   7800     jour 224.heure  3.0    date   8.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978648 0.119921E+01     0.941     0.868     0.942    11.499     0.946
+
+ Ls =    104.0490      tauref(700 Pa,lat=0) =   0.1689316      tau(Viking1) = 
+   0.1517887    
+ Ls =    104.0587      tauref(700 Pa,lat=0) =   0.1687103      tau(Viking1) = 
+   0.1519029    
+ WRITEDIAGFI: date=     8.166667    
+0**********    pas   7840     jour 224.heure  4.0    date   8.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978589 0.117948E+01     0.941     0.871     0.942    11.489     0.947
+
+ Ls =    104.0683      tauref(700 Pa,lat=0) =   0.1684888      tau(Viking1) = 
+   0.1519201    
+ Ls =    104.0780      tauref(700 Pa,lat=0) =   0.1682675      tau(Viking1) = 
+   0.1518544    
+ WRITEDIAGFI: date=     8.208333    
+0**********    pas   7880     jour 224.heure  5.0    date   8.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978528 0.117790E+01     0.941     0.878     0.942    11.470     0.947
+
+ Ls =    104.0877      tauref(700 Pa,lat=0) =   0.1680463      tau(Viking1) = 
+   0.1517002    
+ Ls =    104.0973      tauref(700 Pa,lat=0) =   0.1678248      tau(Viking1) = 
+   0.1514904    
+ WRITEDIAGFI: date=     8.250000    
+0**********    pas   7920     jour 224.heure  6.0    date   8.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978472 0.118834E+01     0.941     0.883     0.942    11.447     0.947
+
+ Ls =    104.1070      tauref(700 Pa,lat=0) =   0.1676035      tau(Viking1) = 
+   0.1512067    
+ Ls =    104.1166      tauref(700 Pa,lat=0) =   0.1673822      tau(Viking1) = 
+   0.1509068    
+ WRITEDIAGFI: date=     8.291667    
+0**********    pas   7960     jour 224.heure  7.0    date   8.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978414 0.119198E+01     0.941     0.883     0.941    11.420     0.947
+
+ Ls =    104.1263      tauref(700 Pa,lat=0) =   0.1671607      tau(Viking1) = 
+   0.1505917    
+ Ls =    104.1359      tauref(700 Pa,lat=0) =   0.1669394      tau(Viking1) = 
+   0.1503045    
+ WRITEDIAGFI: date=     8.333333    
+0**********    pas   8000     jour 224.heure  8.0    date   8.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978357 0.118481E+01     0.941     0.880     0.941    11.390     0.947
+
+ Ls =    104.1456      tauref(700 Pa,lat=0) =   0.1667181      tau(Viking1) = 
+   0.1500829    
+ Ls =    104.1553      tauref(700 Pa,lat=0) =   0.1664967      tau(Viking1) = 
+   0.1499447    
+ WRITEDIAGFI: date=     8.375000    
+0**********    pas   8040     jour 224.heure  9.0    date   8.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978297 0.118636E+01     0.941     0.874     0.941    11.364     0.947
+
+ Ls =    104.1649      tauref(700 Pa,lat=0) =   0.1662754      tau(Viking1) = 
+   0.1497607    
+ Ls =    104.1746      tauref(700 Pa,lat=0) =   0.1660541      tau(Viking1) = 
+   0.1495849    
+ WRITEDIAGFI: date=     8.416667    
+0**********    pas   8080     jour 224.heure 10.0    date   8.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978236 0.120925E+01     0.941     0.878     0.941    11.348     0.947
+
+ Ls =    104.1842      tauref(700 Pa,lat=0) =   0.1658326      tau(Viking1) = 
+   0.1493677    
+ Ls =    104.1939      tauref(700 Pa,lat=0) =   0.1656114      tau(Viking1) = 
+   0.1491735    
+ WRITEDIAGFI: date=     8.458333    
+0**********    pas   8120     jour 224.heure 11.0    date   8.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978175 0.123919E+01     0.941     0.881     0.941    11.340     0.947
+
+ Ls =    104.2036      tauref(700 Pa,lat=0) =   0.1653901      tau(Viking1) = 
+   0.1489808    
+ Ls =    104.2132      tauref(700 Pa,lat=0) =   0.1651686      tau(Viking1) = 
+   0.1488290    
+ WRITEDIAGFI: date=     8.500000    
+0**********    pas   8160     jour 224.heure 12.0    date   8.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978113 0.125413E+01     0.941     0.871     0.941    11.337     0.947
+
+ Ls =    104.2229      tauref(700 Pa,lat=0) =   0.1649473      tau(Viking1) = 
+   0.1487000    
+ Ls =    104.2325      tauref(700 Pa,lat=0) =   0.1647260      tau(Viking1) = 
+   0.1485647    
+ WRITEDIAGFI: date=     8.541667    
+0**********    pas   8200     jour 224.heure 13.0    date   8.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.978051 0.125156E+01     0.940     0.851     0.941    11.330     0.947
+
+ Ls =    104.2422      tauref(700 Pa,lat=0) =   0.1645045      tau(Viking1) = 
+   0.1484083    
+ Ls =    104.2518      tauref(700 Pa,lat=0) =   0.1642832      tau(Viking1) = 
+   0.1482070    
+ WRITEDIAGFI: date=     8.583333    
+0**********    pas   8240     jour 224.heure 14.0    date   8.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977987 0.123195E+01     0.940     0.840     0.941    11.318     0.947
+
+ Ls =    104.2615      tauref(700 Pa,lat=0) =   0.1640619      tau(Viking1) = 
+   0.1480253    
+ Ls =    104.2712      tauref(700 Pa,lat=0) =   0.1638405      tau(Viking1) = 
+   0.1478621    
+ WRITEDIAGFI: date=     8.625000    
+0**********    pas   8280     jour 224.heure 15.0    date   8.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977923 0.121232E+01     0.940     0.833     0.941    11.302     0.947
+
+ Ls =    104.2808      tauref(700 Pa,lat=0) =   0.1636192      tau(Viking1) = 
+   0.1476712    
+ Ls =    104.2905      tauref(700 Pa,lat=0) =   0.1633979      tau(Viking1) = 
+   0.1474263    
+ WRITEDIAGFI: date=     8.666667    
+0**********    pas   8320     jour 224.heure 16.0    date   8.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977860 0.120904E+01     0.940     0.831     0.941    11.287     0.947
+
+ Ls =    104.3002      tauref(700 Pa,lat=0) =   0.1631764      tau(Viking1) = 
+   0.1471746    
+ Ls =    104.3098      tauref(700 Pa,lat=0) =   0.1629552      tau(Viking1) = 
+   0.1469206    
+ WRITEDIAGFI: date=     8.708333    
+0**********    pas   8360     jour 224.heure 17.0    date   8.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977801 0.120379E+01     0.940     0.835     0.941    11.273     0.947
+
+ Ls =    104.3195      tauref(700 Pa,lat=0) =   0.1627339      tau(Viking1) = 
+   0.1466405    
+ Ls =    104.3291      tauref(700 Pa,lat=0) =   0.1625124      tau(Viking1) = 
+   0.1463453    
+ WRITEDIAGFI: date=     8.750000    
+0**********    pas   8400     jour 224.heure 18.0    date   8.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977737 0.119898E+01     0.940     0.841     0.941    11.261     0.947
+
+ Ls =    104.3388      tauref(700 Pa,lat=0) =   0.1622911      tau(Viking1) = 
+   0.1460135    
+ Ls =    104.3485      tauref(700 Pa,lat=0) =   0.1620698      tau(Viking1) = 
+   0.1456956    
+ WRITEDIAGFI: date=     8.791667    
+0**********    pas   8440     jour 224.heure 19.0    date   8.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977673 0.118544E+01     0.940     0.847     0.941    11.254     0.946
+
+ Ls =    104.3582      tauref(700 Pa,lat=0) =   0.1618484      tau(Viking1) = 
+   0.1453518    
+ Ls =    104.3678      tauref(700 Pa,lat=0) =   0.1616271      tau(Viking1) = 
+   0.1450150    
+ WRITEDIAGFI: date=     8.833333    
+0**********    pas   8480     jour 224.heure 20.0    date   8.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977608 0.115975E+01     0.940     0.844     0.941    11.255     0.946
+
+ Ls =    104.3775      tauref(700 Pa,lat=0) =   0.1614058      tau(Viking1) = 
+   0.1447216    
+ Ls =    104.3871      tauref(700 Pa,lat=0) =   0.1611843      tau(Viking1) = 
+   0.1444756    
+ WRITEDIAGFI: date=     8.875000    
+0**********    pas   8520     jour 224.heure 21.0    date   8.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977543 0.114786E+01     0.940     0.836     0.941    11.274     0.946
+
+ Ls =    104.3968      tauref(700 Pa,lat=0) =   0.1609630      tau(Viking1) = 
+   0.1443099    
+ Ls =    104.4065      tauref(700 Pa,lat=0) =   0.1607417      tau(Viking1) = 
+   0.1443775    
+ WRITEDIAGFI: date=     8.916667    
+0**********    pas   8560     jour 224.heure 22.0    date   8.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977479 0.116289E+01     0.940     0.838     0.941    11.311     0.945
+
+ Ls =    104.4161      tauref(700 Pa,lat=0) =   0.1605203      tau(Viking1) = 
+   0.1448257    
+ Ls =    104.4258      tauref(700 Pa,lat=0) =   0.1602990      tau(Viking1) = 
+   0.1454165    
+ WRITEDIAGFI: date=     8.958333    
+0**********    pas   8600     jour 224.heure 23.0    date   8.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977418 0.119562E+01     0.940     0.854     0.941    11.363     0.945
+
+ Ls =    104.4354      tauref(700 Pa,lat=0) =   0.1600777      tau(Viking1) = 
+   0.1456771    
+ Ls =    104.4451      tauref(700 Pa,lat=0) =   0.1598562      tau(Viking1) = 
+   0.1457640    
+ WRITEDIAGFI: date=     9.000000    
+0**********    pas   8640     jour 225.heure  0.0    date   9.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977355 0.122665E+01     0.940     0.873     0.941    11.417     0.945
+
+ LTE rad. calculations up to layer            24
+ Ls =    104.4548      tauref(700 Pa,lat=0) =   0.1596665      tau(Viking1) = 
+   0.1458471    
+ Ls =    104.4644      tauref(700 Pa,lat=0) =   0.1594785      tau(Viking1) = 
+   0.1459039    
+ WRITEDIAGFI: date=     9.041667    
+0**********    pas   8680     jour 225.heure  1.0    date   9.04167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977296FORTRAN STOP
+ 0.123829E+01     0.940     0.880     0.941    11.459     0.945
+
+ Ls =    104.4741      tauref(700 Pa,lat=0) =   0.1592904      tau(Viking1) = 
+   0.1459058    
+ Ls =    104.4838      tauref(700 Pa,lat=0) =   0.1591024      tau(Viking1) = 
+   0.1459525    
+ WRITEDIAGFI: date=     9.083333    
+0**********    pas   8720     jour 225.heure  2.0    date   9.08333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977235 0.122600E+01     0.940     0.871     0.941    11.480     0.945
+
+ Ls =    104.4934      tauref(700 Pa,lat=0) =   0.1589143      tau(Viking1) = 
+   0.1459866    
+ Ls =    104.5031      tauref(700 Pa,lat=0) =   0.1587262      tau(Viking1) = 
+   0.1460470    
+ WRITEDIAGFI: date=     9.125000    
+0**********    pas   8760     jour 225.heure  3.0    date   9.12500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977174 0.120216E+01     0.940     0.865     0.941    11.482     0.945
+
+ Ls =    104.5127      tauref(700 Pa,lat=0) =   0.1585382      tau(Viking1) = 
+   0.1460855    
+ Ls =    104.5224      tauref(700 Pa,lat=0) =   0.1583502      tau(Viking1) = 
+   0.1460957    
+ WRITEDIAGFI: date=     9.166667    
+0**********    pas   8800     jour 225.heure  4.0    date   9.16667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977114 0.118264E+01     0.940     0.863     0.941    11.471     0.945
+
+ Ls =    104.5321      tauref(700 Pa,lat=0) =   0.1581620      tau(Viking1) = 
+   0.1459995    
+ Ls =    104.5418      tauref(700 Pa,lat=0) =   0.1579740      tau(Viking1) = 
+   0.1458519    
+ WRITEDIAGFI: date=     9.208333    
+0**********    pas   8840     jour 225.heure  5.0    date   9.20833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.977053 0.118259E+01     0.940     0.865     0.941    11.451     0.945
+
+ Ls =    104.5514      tauref(700 Pa,lat=0) =   0.1577860      tau(Viking1) = 
+   0.1456298    
+ Ls =    104.5611      tauref(700 Pa,lat=0) =   0.1575978      tau(Viking1) = 
+   0.1453511    
+ WRITEDIAGFI: date=     9.250000    
+0**********    pas   8880     jour 225.heure  6.0    date   9.25000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976995 0.119519E+01     0.940     0.864     0.941    11.426     0.946
+
+ Ls =    104.5708      tauref(700 Pa,lat=0) =   0.1574098      tau(Viking1) = 
+   0.1450156    
+ Ls =    104.5804      tauref(700 Pa,lat=0) =   0.1572218      tau(Viking1) = 
+   0.1446447    
+ WRITEDIAGFI: date=     9.291667    
+0**********    pas   8920     jour 225.heure  7.0    date   9.29167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976940 0.120067E+01     0.940     0.851     0.940    11.397     0.946
+
+ Ls =    104.5901      tauref(700 Pa,lat=0) =   0.1570336      tau(Viking1) = 
+   0.1442629    
+ Ls =    104.5998      tauref(700 Pa,lat=0) =   0.1568456      tau(Viking1) = 
+   0.1439015    
+ WRITEDIAGFI: date=     9.333333    
+0**********    pas   8960     jour 225.heure  8.0    date   9.33333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976880 0.119291E+01     0.940     0.831     0.940    11.366     0.946
+
+ Ls =    104.6095      tauref(700 Pa,lat=0) =   0.1566576      tau(Viking1) = 
+   0.1435985    
+ Ls =    104.6191      tauref(700 Pa,lat=0) =   0.1564694      tau(Viking1) = 
+   0.1433792    
+ WRITEDIAGFI: date=     9.375000    
+0**********    pas   9000     jour 225.heure  9.0    date   9.37500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976821 0.119168E+01     0.940     0.813     0.940    11.339     0.946
+
+ Ls =    104.6287      tauref(700 Pa,lat=0) =   0.1562814      tau(Viking1) = 
+   0.1431229    
+ Ls =    104.6384      tauref(700 Pa,lat=0) =   0.1560934      tau(Viking1) = 
+   0.1428674    
+ WRITEDIAGFI: date=     9.416667    
+0**********    pas   9040     jour 225.heure 10.0    date   9.41667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976761 0.121172E+01     0.939     0.806     0.940    11.322     0.945
+
+ Ls =    104.6481      tauref(700 Pa,lat=0) =   0.1559053      tau(Viking1) = 
+   0.1425785    
+ Ls =    104.6578      tauref(700 Pa,lat=0) =   0.1557172      tau(Viking1) = 
+   0.1422995    
+ WRITEDIAGFI: date=     9.458333    
+0**********    pas   9080     jour 225.heure 11.0    date   9.45833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976701 0.124024E+01     0.939     0.802     0.940    11.313     0.945
+
+ Ls =    104.6674      tauref(700 Pa,lat=0) =   0.1555292      tau(Viking1) = 
+   0.1420225    
+ Ls =    104.6771      tauref(700 Pa,lat=0) =   0.1553411      tau(Viking1) = 
+   0.1417754    
+ WRITEDIAGFI: date=     9.500000    
+0**********    pas   9120     jour 225.heure 12.0    date   9.50000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976637 0.125459E+01     0.939     0.791     0.940    11.307     0.945
+
+ Ls =    104.6868      tauref(700 Pa,lat=0) =   0.1551531      tau(Viking1) = 
+   0.1415493    
+ Ls =    104.6964      tauref(700 Pa,lat=0) =   0.1549650      tau(Viking1) = 
+   0.1413283    
+ WRITEDIAGFI: date=     9.541667    
+0**********    pas   9160     jour 225.heure 13.0    date   9.54167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976573 0.125213E+01     0.939     0.781     0.940    11.300     0.945
+
+ Ls =    104.7061      tauref(700 Pa,lat=0) =   0.1547769      tau(Viking1) = 
+   0.1410834    
+ Ls =    104.7158      tauref(700 Pa,lat=0) =   0.1545888      tau(Viking1) = 
+   0.1407929    
+ WRITEDIAGFI: date=     9.583333    
+0**********    pas   9200     jour 225.heure 14.0    date   9.58333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976511 0.123305E+01     0.939     0.779     0.940    11.289     0.945
+
+ Ls =    104.7255      tauref(700 Pa,lat=0) =   0.1544008      tau(Viking1) = 
+   0.1405167    
+ Ls =    104.7351      tauref(700 Pa,lat=0) =   0.1542127      tau(Viking1) = 
+   0.1402552    
+ WRITEDIAGFI: date=     9.625000    
+0**********    pas   9240     jour 225.heure 15.0    date   9.62500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976448 0.121343E+01     0.939     0.779     0.940    11.276     0.945
+
+ Ls =    104.7448      tauref(700 Pa,lat=0) =   0.1540247      tau(Viking1) = 
+   0.1399645    
+ Ls =    104.7545      tauref(700 Pa,lat=0) =   0.1538367      tau(Viking1) = 
+   0.1396333    
+ WRITEDIAGFI: date=     9.666667    
+0**********    pas   9280     jour 225.heure 16.0    date   9.66667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976389 0.121112E+01     0.939     0.780     0.940    11.264     0.945
+
+ Ls =    104.7641      tauref(700 Pa,lat=0) =   0.1536485      tau(Viking1) = 
+   0.1393018    
+ Ls =    104.7738      tauref(700 Pa,lat=0) =   0.1534605      tau(Viking1) = 
+   0.1389594    
+ WRITEDIAGFI: date=     9.708333    
+0**********    pas   9320     jour 225.heure 17.0    date   9.70833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976324 0.120712E+01     0.939     0.784     0.940    11.253     0.945
+
+ Ls =    104.7835      tauref(700 Pa,lat=0) =   0.1532725      tau(Viking1) = 
+   0.1385929    
+ Ls =    104.7932      tauref(700 Pa,lat=0) =   0.1530843      tau(Viking1) = 
+   0.1382191    
+ WRITEDIAGFI: date=     9.750000    
+0**********    pas   9360     jour 225.heure 18.0    date   9.75000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976262 0.120383E+01     0.939     0.797     0.940    11.241     0.945
+
+ Ls =    104.8028      tauref(700 Pa,lat=0) =   0.1528963      tau(Viking1) = 
+   0.1378100    
+ Ls =    104.8125      tauref(700 Pa,lat=0) =   0.1527083      tau(Viking1) = 
+   0.1374120    
+ WRITEDIAGFI: date=     9.791667    
+0**********    pas   9400     jour 225.heure 19.0    date   9.79167    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976196 0.119132E+01     0.939     0.807     0.940    11.234     0.945
+
+ Ls =    104.8222      tauref(700 Pa,lat=0) =   0.1525201      tau(Viking1) = 
+   0.1370037    
+ Ls =    104.8318      tauref(700 Pa,lat=0) =   0.1523321      tau(Viking1) = 
+   0.1365986    
+ WRITEDIAGFI: date=     9.833333    
+0**********    pas   9440     jour 225.heure 20.0    date   9.83333    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976132 0.116520E+01     0.939     0.806     0.940    11.235     0.944
+
+ Ls =    104.8415      tauref(700 Pa,lat=0) =   0.1521441      tau(Viking1) = 
+   0.1362339    
+ Ls =    104.8512      tauref(700 Pa,lat=0) =   0.1519559      tau(Viking1) = 
+   0.1359024    
+ WRITEDIAGFI: date=     9.875000    
+0**********    pas   9480     jour 225.heure 21.0    date   9.87500    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976068 0.115424E+01     0.939     0.813     0.940    11.253     0.944
+
+ Ls =    104.8609      tauref(700 Pa,lat=0) =   0.1517679      tau(Viking1) = 
+   0.1356426    
+ Ls =    104.8705      tauref(700 Pa,lat=0) =   0.1515799      tau(Viking1) = 
+   0.1355923    
+ WRITEDIAGFI: date=     9.916667    
+0**********    pas   9520     jour 225.heure 22.0    date   9.91667    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.976004 0.116966E+01     0.939     0.844     0.940    11.291     0.944
+
+ Ls =    104.8802      tauref(700 Pa,lat=0) =   0.1513918      tau(Viking1) = 
+   0.1359017    
+ Ls =    104.8899      tauref(700 Pa,lat=0) =   0.1512037      tau(Viking1) = 
+   0.1363375    
+ WRITEDIAGFI: date=     9.958333    
+0**********    pas   9560     jour 225.heure 23.0    date   9.95833    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.975940 0.120237E+01     0.939     0.865     0.940    11.342     0.944
+
+ Ls =    104.8995      tauref(700 Pa,lat=0) =   0.1510157      tau(Viking1) = 
+   0.1364686    
+ Ls =    104.9092      tauref(700 Pa,lat=0) =   0.1508276      tau(Viking1) = 
+   0.1364472    
+ PHYSIQ: for physdem ztime_fin =    1.000000    
+ ngridmx:          3010
+ WRITEDIAGFI: date=     10.00000    
+  Appel test_period avant redem          9600
+ Enregistrement pour             1    0.000000    
+  ----   Test_period apres continue   OK ! -----         9600
+0**********    pas   9600     jour 226.heure  0.0    date  10.00000    **********
+          masse    rmsdpdt       energie  enstrophie  entropie   rmsv    mt.ang
+        0.975880 0.123216E+01     0.939     0.861     0.940    11.395     0.943
+
+ in abort_gcm
+ Stopping in gcm                 
+ Reason = 
+ Simulation finished                                                             
+ Everything is cool
Index: trunk/mesoscale/LMDZ.MARS/myGCM/newstart.e
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/newstart.e	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/newstart.e	(revision 57)
@@ -0,0 +1,1 @@
+link ../newstart.e
Index: trunk/mesoscale/LMDZ.MARS/myGCM/run.def
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/run.def	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/run.def	(revision 57)
@@ -0,0 +1,1 @@
+link ../in_lmdz_mars/myGCM/run.def.INIT
Index: trunk/mesoscale/LMDZ.MARS/myGCM/run0
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/run0	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/run0	(revision 57)
@@ -0,0 +1,1 @@
+link ../deftank_gcm/run0
Index: trunk/mesoscale/LMDZ.MARS/myGCM/run_mcd_3days
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/run_mcd_3days	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/run_mcd_3days	(revision 57)
@@ -0,0 +1,1 @@
+link ../in_lmdz_mars/myGCM/run_mcd_3days
Index: trunk/mesoscale/LMDZ.MARS/myGCM/start.nc
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/start.nc	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/start.nc	(revision 57)
@@ -0,0 +1,1 @@
+link /d5/aslmd/LMD_MM_MARS_DATA/STARTBASE_64_48_25/start215.nc
Index: trunk/mesoscale/LMDZ.MARS/myGCM/start_archive.nc
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/start_archive.nc	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/start_archive.nc	(revision 57)
@@ -0,0 +1,1 @@
+link /u/forget/WWW/datagcm/Starts/start_archive_64x48x25_t2.nc
Index: trunk/mesoscale/LMDZ.MARS/myGCM/startfi.nc
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/startfi.nc	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/startfi.nc	(revision 57)
@@ -0,0 +1,1 @@
+link /d5/aslmd/LMD_MM_MARS_DATA/STARTBASE_64_48_25/startfi215.nc
Index: trunk/mesoscale/LMDZ.MARS/myGCM/what_I_need.info
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/what_I_need.info	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/what_I_need.info	(revision 57)
@@ -0,0 +1,1 @@
+link ../in_lmdz_mars/myGCM/what_I_need.info
Index: trunk/mesoscale/LMDZ.MARS/myGCM/z2sig.def
===================================================================
--- trunk/mesoscale/LMDZ.MARS/myGCM/z2sig.def	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/myGCM/z2sig.def	(revision 57)
@@ -0,0 +1,1 @@
+link ../deftank_gcm/z2sig.def
Index: trunk/mesoscale/LMDZ.MARS/writediagfi.info
===================================================================
--- trunk/mesoscale/LMDZ.MARS/writediagfi.info	(revision 57)
+++ trunk/mesoscale/LMDZ.MARS/writediagfi.info	(revision 57)
@@ -0,0 +1,1 @@
+link in_lmdz_mars/writediagfi.info
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/LMDZ.MARS.source.txt
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/LMDZ.MARS.source.txt	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/LMDZ.MARS.source.txt	(revision 57)
@@ -0,0 +1,306 @@
+--------------------------------------------------------------------
+Changes in the LMD MARS GCM reference sources 
+(most recent version available in LMDZ.MARS.source.tar)
+--------------------------------------------------------------------
+
+09/2008 dyn3d/physdem1.F
+Correct possible bugs on some computers + english text & comments
+
+09/2008 dyn3d/defrun_new.F
+Corrected small bug (tapedef argument should not be altered)
+
+09/2008 dyn3d/eofdump.F
+Corrected small bug in the sampling time
+
+09/2008 dyn3d/vanleer.F
+removed inapropriate 'EXTERNAL' statement
+
+O9/2008 aeronomars/euvheat.F
+removed print of 'ngrid','nlayer' (undefined and unused variables)
+
+O9/2008 phymars/mkstat.F90
+Cleaned up (removed unused variables)
+
+09/2008 phymars/uniplot.F bibio/uniplot.F are removed because useless
+
+O9/2008 phymars/comcstfi.h
+09/2008 phymars/writediagfi.F
+08/2007 phymars/tabfi.F
+Cosmetic: english text & comments
+
+09/2008 dyn3d/iniwrite.F => phymars/iniwrite.F 
+- moved it from dyn3d to phymars
+- cleanup & english
+
+09/2008 phymars/physdem1.F
+commented unused (wrong) 'external' qualifiers
+
+09/2008 phymars/orosetup.F
+Replaced logical 'xor' with 'neqv' (for standards compliance)
+
+09/2008 phymars/physiq.F
+- Change to ice albedo to fit new TES observation (Franck L.)
+- cleanup + comments in english (Ehouarn)
+
+09/2008 phymars/watercloud.F
+cleaned version with reduced number of nuclei, and TES like output. 
+
+09/2008 phymars/growthrate.F
+updated to improved version provided by F. Montmessin (Feb 2006...)
+ 
+09/2008 phymars/vdifc.F
+Change to remove an old quick fix to take into account condensation in
+vertical diffusion
+
+09/2008  
+- phymars/mkstat.F90 
+- phymars/def_var.F90
+Slight change to improve compilation (include => #include)
+
+O7/2008 MAJOR CHANGE to solve the "warm polar night" problem
+- dyn3d/addfi.F
+- dyn3d/gcm.F
+Recompute mass after incrementation of ps in addfi.F (masse is added in the argument
+list of addfi). 
+Also : the call of groupeun is now controlled by a flag.  
+
+
+07/2008 phymars/physiq.F
+- Change made (by Aymeric) to improve the models when iradia > 1 (iradia
+  is set is callphys.def). 
+(i.e. when one don't want to compute radiative transfer at every timestep):
+The change has no impact when iradia=1
+=> The net radiative surface flux  "fluxrad" is computed outside the
+test on iradia    
+=> Add intermediate variable "fluxrad_sky" (rad. flux from sky absorbed 
+by surface) to be saved when rad. transfer is not computed.
+- Cleaning of old commented lines about radiative transfer in clouds
+
+
+07/2008 Utility concatnc.F90 (not used by the gcm): improvement in order
+to 1) concatenate 1D variable and 2) increase the number of input files
+up to 1000
+
+12/2007 dyn3d/lect_start_archive.F
+some old stuuf is commented to avoid bugs with some start_archive with
+many tracers
+
+12/2007 dyn3d/dump2d.F
+Changed to improve crazy output to screen with newstart...
+
+12/2007 bibio/mxva.F
+Changed to avoid array bounds problems on some compilers
+
+12/2007 
+aeronomars/conduction.F
+aeronomars/molvis.F
+Changed to ensure variable initialisation on some compilers. 
+
+12/2007 phymars/convadj.F
+Improvement regarding convection in the polar night
+
+12/2007 
+-phymars/callsedim.F  
+-phymars/initracer.F  
+-phymars/tracer.h
+-phymars/callsedim2q.F
+Changed to initialize tracer particle densities in initracer.F, and
+transfer it with common in tracer.h
+
+12/2007 script "makegcm" "create_make_gcm"
+Improved to separate object compiled files in LIBO depending on the type
+of machine you are (32bits or 64bits). Also allow to compute with LMDZ.2
+dynamics.  
+
+10/2007 Utility lslin.F90 (not used by the gcm)
+changed evaluation of 'start_var' from hard-coded values to a computed value
+
+09/2007 phymars/wstats.F90 and phymars/readtesassim.F90
+change " include" to "#include" to force recompilation by makegcm
+
+08/2007 dyn3d/newstart.F90
+Translate french questions asked by program in english...
+Improve options to remove topography... (for intercomparison)
+
+08/2007 phymars/dustopacity.F
+add possibility for scenario iaervar=5 (for paleoclimate...)
+
+08/2007 phymars/tabfi.F
+Translate french questions asked by program in english...
+
+11/2006 phymars/convadj.F
+Correction to remove a bug for compiler which did not "save" variable 
+by default (e.g. pgf on opteron, or g95)
+
+11/2006 aeronomars/thermosphere.F
+Correction to remove a bug if tracer=F and callthermos=T 
+
+10/2006 phymars/readtesassim.F90
+Correction to use dust scenario MY24 at high horizontal resolution
+
+10/2006 dyn3d/dynredem.F and phymars/physdem1.F
+Syntax changes to avoid problem when writing start files when compiling
+on 64bits computers.
+
+05/2006 : phymars/writediagfi.F
+Add a test to be sure not to use writediagfi with 1D version of GCM 
+
+09/2005 : phymars/mucorr.F
+Fix a weird bug that occured when running the model with "Diurnal=F"
+on Linux, pgf90
+
+-----------------------------------
+Update in june 2005
+-----------------------------------
+
+06/2005 : deftank/run0
+Improved so that the "run manager" run0 send you an E-mail when a run crash
+(this can easily be commented)
+
+06/2005 : deftank/run_mcd and deftank/callphys.def
+Cosmetic changes to make thing clearer in english
+
+06/2005 : makegcm
+IMPORTANT FOR 1D GCM VERSION ON LINUX : modified to follow a change in
+the Linux syntax of "sed"
+
+06/2005 : aeronomars/calchim.F
+NEW version provided by S. Lebonnois and F. Lefevre on May, 11, 2005
+("Cosmetic changes")+syntax changes by FF (1 line > 72 characters)
+
+06/2005 : phymars/convadj.F
+Modified if one tracer is CO2, take into account the
+Molecular mass variation (e.g. when CO2 condense) to trigger convection
+
+06/2005 : phymars/newcondens.F
+The CO2 deplation induced convection is now skipped, since it is properly
+done in convadj.F (see above)
+
+06/2005 : phymars/watercloud.F
+IMPORTANT (especially for PALEOCLIMATE) : correction if a lot of subliming 
+CO2 fills the 1st layer. The number of input is modified (see below)
+
+06/2005 : phymars/physiq.F
+- Change in the input argument of watercloud.F : "pdpsrf" is added (see
+above)
+- If "caps", the cold trap at the south pole is only active for
+obliquity lower than 27 deg (only useful for paleoclimate...)
+
+06/2005 : dyn3d/groupe.F
+Just cleaned to remove ambiguity of where "ngroup" is set (in groupeun, and
+not in groupe). 
+
+06/2005 : phymars/inistats.F
+remove declaration of "pseudoalt", already in comvert.h 
+(was a problem only for some compiler)
+
+06/2005 : dyn3d/newstart.F
+Cosmetic changes in some format for compatibility with gnu compiler
+
+06/2005 : dyn3d/readhead_NC.F
+Cosmetic changes in some format for compatibility with gnu compiler
+
+06/2005 : dyn3d/sortvarc.F
+Cosmetic changes in some format for compatibility with gnu compiler
+
+06/2005 : phymars/testphys1d.F
+Cleaning and changes in declaration for compatibility with gnu compiler
+
+06/2005 : phymars/lwflux.F
+Initialisation of "ksidb" for compiler that does not unitialized variable.
+
+06/2005 : phymars/lwxd.F
+Initialisation of "ksi_emis" for compiler that does not unitialized variable.
+
+06/2005 : phymars/nirco2abs.F
+Negligible change of one loop for compiler that does not like loop on real.
+
+06/2005 : aeronomars/paramfoto.F
+Negligible change of one loop for compiler that does not like loop on real.
+
+
+--------------------------------------------------------------
+Change in December 2004 - January 2005 
+--------------------------------------------------------------
+
+01/2005 : aeronomars/euvheat.F
+IMPORTANT FOR THERMOSPHERE : correction to avoid EUV flux time variation 
+and keep it constant throughout the run
+
+01/2005 : LMDZ.MARS/create_make_gcm
+add phymars on line 187 to ensure recompilation of aeronomars subroutines
+when any *.h file is updated in phymars
+
+01/2005 : dyn3d/dynetat0.F
+Add an option to reindex the tracer when using newstart if needed
+
+01/2005 : phymars/phyetat0.F
+Fix a bug when using newstart with more tracers than in old startfi
+Add an option to reindex the surface tracer if needed
+
+12/2004 : phymars/watercloud.F
+IMPORTANT: Several Changes to fix a bug that made watercloud
+to create negative mixing ratio in some conditions (past climate)
+
+12/2004 : dyn3d/interp_horiz.F
+IMPORTANT : add a test to fix a bug when using newstart with 
+a new grid size.
+
+12/2004 : phymars/vdifc.F
+FOR compilation on DEC machine :
+Just change order of declaration of pqsurf(ngrid,nq
+
+12/2004 : phymars/phyetat0.F
+FOR compilation on DEC machine :Just change order of declaration 
+
+12/2004 : dyn3d/addfi.F
+FOR compilation on DEC machine : qtestt = 1.0e-30 (before: qtestt = 1.0e-40)
+
+12/2004 : LMDZ.MARS/makefile
+Add new option to allow compilation on DEC machine
+
+--------------------------------------------------------------
+Change in August-september 2004 : before production of MCD V4.0
+--------------------------------------------------------------
+
+09/2004 : phymars/eofdump.F
+Change to store density in EOF to build Mars Climate Database
+
+09/2004 : phymars/physiq.F
+add rho in the input of eofdump:
+CALL eofdump(ngrid, nlayer, zu, zv, zt, rho, ps)
+
+09/2004 : phymars/ineofdump.F
+Change to store hybrid coordinates in EOF to build Mars Climate Database
+
+
+08/2004 : dyn3d/inidissip.F
+Form change to simplify the choice of dissipation parameters
+and use the same code for the thermosphere of only atmosphere model
+
+08/2004 : dyn3d/newstart.F
+Add an option "q=x" to initialise tracer manually
+
+08/2004 : aeronomars/chimiedata.h
+remove mmol,noms (now in tracer.h common)
+
+08/2004 : In aeronomars: calchim.F, concentrations.F, euvheat.F,
+inichim_newstart.F, moldiff.F, moldiffcoeff.F, perosat.F
+Add : #include "tracer.h"  (where tracer names are now)
+
+08/2004 : phymars/inifis.F
+Change some test on callphys.def options to allow any tracer transport...
+
+08/2004 : phymars/initracer
+Initialization of tracer name "noms(iq)" usable in many place
+
+08/2004 : phymars/tracer.h
+add noms,mmol to the common tracer
+
+08/2004 : phymars/newcondens.F
+IMPORTANT : major changes to allow proper treatment of non volatile 
+gaz enrichment when CO2 condense and depletion when CO2 sublime
+
+08/2004 : phymars/writediagfi.F
+remove the "abort" command so that the run does not stop due to a NETCDF bug
+(NETCDF cannot write in file larger than 2098184 kb
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/callphys.def
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/callphys.def	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/callphys.def	(revision 57)
@@ -0,0 +1,94 @@
+General options
+~~~~~~~~~~~~~~~
+tracer    (Run with or without tracer transport ?)
+F
+diurnal   (Diurnal cycle ?  if diurnal=F, diurnal averaged solar heating)
+T
+season    (Seasonal cycle ? if season=F, Ls stays constant like in "start")
+T
+lwrite    (want some more output on the screen ?) 
+F
+stats     (Saving statistics in file "stats" ?)
+T
+calleofdump (Saving EOF profiles in file "profiles" for Climate Database ?)
+F
+Dust scenario. Used if the dust is prescribed (i.e. if tracer=F or active=F)
+~~~~~~~~~~~~~
+iaervar  (=1 Dust opt.deph read in startfi; =2 Viking scenario; =3 MGS scenario)
+4        (=4 Mars Year 24 from TES assimilation) 
+iddist  (Dust vertical distribution: =0: old distrib. (Pollack90) 
+3       (=1: top set by "topdustref"; =2: Viking scenario; =3 MGS scenario )
+topdustref (Dust top altitude (km). Matter only if iddist=1)
+55.
+Physical Parameterizations :
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+callrad   (call radiative transfer ?)
+T
+callnlte (call NLTE radiative schemes ?   matter only if callrad=T)
+T
+callnirco2 (call CO2 NIR absorption ?   matter only if callrad=T)
+T
+calldifv  (call turbulent vertical diffusion ?)
+T
+calladj   (call convective adjustment ?)
+T
+callcond  (call CO2 condensation ?)
+T
+callsoil  (call thermal conduction in the soil ?)
+T
+calllott  (call Lott's gravity wave/subgrid topography scheme ?)
+T
+Radiative transfer options :
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+iradia    (the rad.transfer is computed every "iradia" physical timestep)
+1
+callg2d   (Output of the exchange coefficient mattrix ? for diagnostic only)
+F
+rayleigh  (Rayleigh scattering : should be =F for now)
+F
+Tracer (dust water, ice and/or chemical species) options (use if tracer=T) :
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+dustbin    (DUST: Transported dust ? (if >0, uses q(1) to q(dustbin))
+0
+active     (DUST: Radiatively active dust ? (uses q(1) to q(dustbin))
+F
+doubleq    (DUST: needs dustbin=1, use mass (q(1)) and number (q(2)) mixing ratio to predict dust size ?)
+F
+lifting    (DUST: lifted by GCM surface winds ?)
+F
+dustdevil  (DUST: lifted by dust devils ?)
+F
+scavenging (DUST: Scavenging by CO2 snowfall ?)
+F
+sedimentation (DUST/WATERICE: Gravitationnal sedimentation ?)
+F              (set to T to simulate water cycle with clouds)                
+iceparty   (WATERICE: includes water ice: q(nqmx-1)). "water" must be T !
+F
+activice   (WATERICE: Radiatively active transported atmospheric water ice ?)
+F
+water      (WATER: Compute water cycle using q(nqmx) )
+F
+caps       (WATER: current permanent caps at both poles. T IS RECOMMENDED
+T          (caps=T means Ncap is a source of water, S pole is a cold trap)
+photochem  (PHOTOCHEMISTRY: chemical species included)
+F
+Thermospheric options (relevant if tracer=T) :
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+callthermos  (call thermosphere ?)
+F
+thermoswater  (WATER: included without cycle	only if water=F)
+F
+callconduct  (call thermal conduction ?     matter only if callthermos=T)
+F
+calleuv  (call EUV heating ?                matter only if callthermos=T)
+F
+callmolvis  (call molecular viscosity ?     matter only if callthermos=T)
+F
+callmoldiff  (call molecular diffusion ?    matter only if callthermos=T)
+F
+thermochem  (call thermospheric photochemistry ?  matter only if callthermos=T)
+F
+solarcondate (date for solar flux calculation: 1985 < date < 2002))
+1993.4       (Solar min=1996.4 ave=1993.4 max=1990.6)
+
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x25
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x25	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x25	(revision 57)
@@ -0,0 +1,152 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+     nday
+ 9999 
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 480
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 120
+
+- 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
+ 1
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- avec ou sans coordonnee hybrides
+ hybrid
+ 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
+ 9000.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 9000.
+
+- 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
+ 10
+
+- choix d'une grille reguliere                                          
+  grireg
+  T
+
+- frequence (en pas) de l'ecriture du fichier diagfi               
+ ecritphy
+ 120
+
+- 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
+ 1.
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.
+
+-  raideur du zoom en  X
+    taux
+ 2.
+
+-  raideur du zoom en  Y
+    tauy
+ 2.
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit.
+  ysinus
+  F
+
+- Avec sponge layer
+  callsponge
+  T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)
+  mode_sponge
+  2
+
+- Sponge:  hauteur de sponge (km)
+  hsponge
+  90
+
+- Sponge:  tetasponge (secondes)
+  tetasponge
+  50000
+
+c   *****************************
+c
+c      Autre reglage possible :
+c
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x32
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x32	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.32x24x32	(revision 57)
@@ -0,0 +1,152 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+     nday
+ 9999
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 480
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 120
+
+- 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
+ 1
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- avec ou sans coordonnee hybrides
+ hybrid
+ 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
+ 9000.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 9000.
+
+- 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
+ 10
+
+- choix d'une grille reguliere                                          
+  grireg
+  T
+
+- frequence (en pas) de l'ecriture du fichier diagfi               
+ ecritphy
+ 120
+
+- 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
+ 1.
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.
+
+-  raideur du zoom en  X
+    taux
+ 2.
+
+-  raideur du zoom en  Y
+    tauy
+ 2.
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit.
+  ysinus
+  F
+
+- Avec sponge layer
+  callsponge
+  T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)
+  mode_sponge
+  2
+
+- Sponge:  hauteur de sponge (km)
+  hsponge
+  130
+
+- Sponge:  tetasponge (secondes)
+  tetasponge
+  50000
+
+c   *****************************
+c
+c      Autre reglage possible :
+c
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x25
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x25	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x25	(revision 57)
@@ -0,0 +1,152 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+     nday
+ 9999
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 960
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 120
+
+- 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
+ 5
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- avec ou sans coordonnee hybrides
+ hybrid
+ 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
+ 4000.
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+ tetagrot
+ 5000.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 5000.
+
+- 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
+ 20
+
+- choix d'une grille reguliere                                          
+  grireg
+  T
+
+- frequence (en pas) de l'ecriture du fichier diagfi               
+ ecritphy
+ 240
+
+- 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
+ 1.
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.
+
+-  raideur du zoom en  X
+    taux
+ 2.
+
+-  raideur du zoom en  Y
+    tauy
+ 2.
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit.
+  ysinus
+  F
+
+- Avec sponge layer
+  callsponge
+  T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)
+  mode_sponge
+  2
+
+- Sponge:  hauteur de sponge (km)
+  hsponge
+  90
+
+- Sponge:  tetasponge (secondes)
+  tetasponge
+  50000
+
+c   *****************************
+c
+c      Autre reglage possible :
+c
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x32
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x32	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x32	(revision 57)
@@ -0,0 +1,152 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+     nday
+ 9999
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 960
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 120
+
+- 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
+ 5
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- avec ou sans coordonnee hybrides
+ hybrid
+ 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
+ 4000.
+
+- temps de dissipation des plus petites long.d ondes pour u,v(nxgradrot)
+ tetagrot
+ 5000.
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 5000.
+
+- 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) USUALLY = daystep/48               
+  iphysiq
+ 20
+
+- choix d'une grille reguliere                                          
+  grireg
+  T
+
+- frequence (en pas) de l'ecriture du fichier diagfi               
+ ecritphy
+ 240
+
+- 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
+ 1.
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.
+
+-  raideur du zoom en  X
+    taux
+ 2.
+
+-  raideur du zoom en  Y
+    tauy
+ 2.
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit.
+  ysinus
+  F
+
+- Avec sponge layer
+  callsponge
+  T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)
+  mode_sponge
+  2
+
+- Sponge:  hauteur de sponge (km)
+  hsponge
+  130
+
+- Sponge:  tetasponge (secondes)
+  tetasponge
+  50000
+
+c   *****************************
+c
+c      Autre reglage possible :
+c
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x50
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x50	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run.def.64x48x50	(revision 57)
@@ -0,0 +1,152 @@
+
+----------------------------------------------------------------------- 
+Parametres de controle du run:                                          
+------------------------------                                          
+
+- Nombre de jours d'integration                                         
+     nday
+ 1
+
+- nombre de pas par jour (multiple de iperiod) ( ici pour  dt = 1 min )      
+ day_step
+ 960
+
+- periode pour le pas Matsuno (en pas)                                  
+  iperiod
+ 5
+
+- periode de sortie des variables de controle (en pas)                  
+  iconser
+ 120
+
+- 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
+ 1
+
+- choix de l'operateur de dissipation (star ou  non star )              
+ lstardis
+ T
+
+- avec ou sans coordonnee hybrides
+ hybrid
+ 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
+ 20000
+
+- temps de dissipation des plus petites long.d ondes pour  h ( divgrad) 
+ tetatemp
+ 20000
+
+- 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
+ 20
+
+- choix d'une grille reguliere                                          
+  grireg
+  T
+
+- frequence (en pas) de l'ecriture du fichier diagfi               
+ ecritphy
+ 240
+
+- 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
+ 1.
+
+- facteur de grossissement du zoom ,selon latitude                      
+ grossismy
+ 1.
+
+-  Fonction  f(y)  hyperbolique  si = .true.  , sinon  sinusoidale         
+  fxyhypb
+ F
+
+- extension en longitude  de la zone du zoom  ( fraction de la zone totale)
+   dzoomx
+ 0.
+
+- extension en latitude de la zone  du zoom  ( fraction de la zone totale)
+   dzoomy
+ 0.
+
+-  raideur du zoom en  X
+    taux
+ 2.
+
+-  raideur du zoom en  Y
+    tauy
+ 2.
+
+-  Fonction  f(y) avec y = Sin(latit.) si = .TRUE. ,  Sinon  y = latit.
+  ysinus
+  F
+
+- Avec sponge layer
+  callsponge
+  T
+
+- Sponge:  mode0(u=v=0), mode1(u=umoy,v=0), mode2(u=umoy,v=vmoy)
+  mode_sponge
+  2
+
+- Sponge:  hauteur de sponge (km)
+  hsponge
+  230
+
+- Sponge:  tetasponge (secondes)
+  tetasponge
+  30000
+
+c   *****************************
+c
+c      Autre reglage possible :
+c
+cc  F ) deltay : deplacement ( en degres ) en  y  de la zone du zoom
+cc                                          dans  *** inigeom.F ***
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run0
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run0	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run0	(revision 57)
@@ -0,0 +1,102 @@
+#!/bin/csh
+###########################################################################
+# Script to perform several chained LMD Mars GCM simulations
+# SET HERE the maximum total number of simulations
+
+set nummax=1
+
+###########################################################################
+
+
+echo "---------------------------------------------------------"
+echo "starting run0"
+
+set dir=`pwd`
+set machine=`hostname`
+set address=`whoami`
+
+# Look for file "num_run" which should contain 
+# the value of the previously computed season
+# (defaults to 0 if file "num_run" does not exist)
+if ( -f num_run ) then
+ echo "found file num_run"
+  set numold=`cat num_run`
+else
+  set numold=0
+endif
+echo "numold is set to" ${numold}
+
+
+# Set value of current season 
+set numnew=${numold}
+@ numnew = ${numnew} + 1
+echo "numnew is set to" ${numnew}
+
+# Look for initialization data files (exit if none found)
+if ( ( -f start${numold}.nc ) && ( -f startfi${numold}.nc ) ) then
+   \cp -f start${numold}.nc start.nc
+   \cp -f startfi${numold}.nc startfi.nc
+else if ( ${numold} == 99999 ) then
+    echo "No run because previous run crashed ! (99999 in num_run)"
+    exit
+else
+   echo "Where is file start"${numold}".nc??"
+   exit
+endif
+
+
+# Run GCM
+nice gcm.e >! lrun${numnew} 
+
+
+# Check if run ended normaly and copy datafiles
+if ( ( -f restartfi.nc ) && ( -f restart.nc ) ) then
+  echo "Run seems to have ended normaly"
+  \mv -f restartfi.nc startfi${numnew}.nc
+  \mv -f restart.nc start${numnew}.nc
+else
+  if ( -f num_run ) then
+    \mv -f num_run num_run.crash
+  else
+    echo "No file num_run to build num_run.crash from !!"
+    # Impose a default value of 0 for num_run
+    echo 0 >! num_run.crash
+  endif
+ echo 99999 >! num_run
+############## To receive an Email message if the run crash ########
+mail -s "crash run GCM" $address <<ENDMAIL
+The run on $machine in $dir has just crashed.
+ENDMAIL
+############################################"" 
+ exit
+endif
+
+# Copy other datafiles that may have been generated
+if ( -f diagfi.nc ) then
+  \mv -f diagfi.nc diagfi${numnew}.nc
+endif
+if ( -f stats.nc ) then
+  \mv -f stats.nc stats${numnew}.nc
+endif
+if ( -f profiles.dat ) then
+  \mv -f profiles.dat profiles${numnew}.dat
+  \mv -f profiles.hdr profiles${numnew}.hdr
+endif
+if ( -f stats.nc ) then
+  \mv -f stats.nc stats${numnew}.nc
+endif
+
+
+# Prepare things for upcoming runs by writing
+# value of computed season in file num_run
+echo ${numnew} >! num_run
+
+# If we are over nummax : stop
+if ( `expr $numnew + 1 \> $nummax ` == 1) then
+   exit
+else
+   \cp -f run0 exe_mars
+   exe_mars
+endif 
+
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_farm
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_farm	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_farm	(revision 57)
@@ -0,0 +1,28 @@
+# Script to submit simulations with the LMD MARS GCM on 
+# a farm of computers using the run manager named "Torque".
+# To run it, just type 
+# > qsub run_farm
+
+# Shell
+#PBS -S /bin/bash
+# Job Name
+#PBS -N run_mars
+# Merge output and error logs
+#PBS -j oe
+
+####################################
+# SELECT HERE THE RUN DURATION CLASS :
+# Queue std(6h) / day / week /infini
+
+#PBS -q std
+
+# Go to present working directory
+cd  $PBS_O_WORKDIR
+
+# SELECT HERE THE TYPE OF SCRIPT TO USE : "run0" OR "run_mcd"
+
+run0
+
+####################################
+
+
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_mcd
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_mcd	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/run_mcd	(revision 57)
@@ -0,0 +1,78 @@
+#!/bin/csh
+##############################################################################
+# Script to run successive monthly (a month spans 30 deg. in Ls)
+# simulations of the LMD Mars GCM.
+# This script uses the following files:
+# - "run0": script to compute a given month
+# - "num_run": single line file containing a value, which is the value of
+#   the 'initializing' month
+# - "run.def.ref": a "run.def" file, exept that variable "nday" is set to 9999
+# - all files usually neaded to run the GCM. Note that initialization
+#   datafiles "start.nc" and "startfi.nc" must be
+#   "start${num_run}.nc" and "startfi${num_run}.nc"
+##############################################################################
+# DON'T FORGET TO:
+# 1) Set the "number of simulation" to 1 in "run0"
+# 2) Copy "run.def" to "run.def.ref" and SET nday to 9999 in run.def.ref
+# 3) uncomment the various lines below (those which begin with "sed ...")
+# 4) If restarting in the middle of a year: 
+#       -Below, Comment all the month already computed
+#       -Write  "N" in file "num_run" if starting from startN.nc !
+##############################################################################
+
+
+# Remove old "error" file (if any) and create a brand new (blank) one
+\rm -f  error; touch error
+
+# 12 martian months (=30°deg Ls) of unequal length (excentric orbit)
+  sed s/9999/61/ run.def.ref >! run.def ; run0 >>& error     #1
+  sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #2
+  sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #3
+  sed s/9999/65/ run.def.ref >! run.def ; run0 >>& error     #4
+  sed s/9999/60/ run.def.ref >! run.def ; run0 >>& error     #5
+  sed s/9999/54/ run.def.ref >! run.def ; run0 >>& error     #6
+  sed s/9999/50/ run.def.ref >! run.def ; run0 >>& error     #7
+  sed s/9999/46/ run.def.ref >! run.def ; run0 >>& error     #8
+  sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #9
+  sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #10
+  sed s/9999/51/ run.def.ref >! run.def ; run0 >>& error     #11 
+  sed s/9999/56/ run.def.ref >! run.def ; run0 >>& error     #12
+#
+# 12 martian months (=30°deg Ls) of unequal length (excentric orbit)
+# sed s/9999/61/ run.def.ref >! run.def ; run0 >>& error     #13
+# sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #14
+# sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #15
+# sed s/9999/65/ run.def.ref >! run.def ; run0 >>& error     #16
+# sed s/9999/60/ run.def.ref >! run.def ; run0 >>& error     #17
+# sed s/9999/54/ run.def.ref >! run.def ; run0 >>& error     #18
+# sed s/9999/50/ run.def.ref >! run.def ; run0 >>& error     #19
+# sed s/9999/46/ run.def.ref >! run.def ; run0 >>& error     #20
+# sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #21
+# sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #22
+# sed s/9999/51/ run.def.ref >! run.def ; run0 >>& error     #23
+# sed s/9999/56/ run.def.ref >! run.def ; run0 >>& error     #24
+#
+# 12 martian months (=30°deg Ls) of unequal length (excentric orbit)
+# sed s/9999/61/ run.def.ref >! run.def ; run0 >>& error     #25
+# sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #26
+# sed s/9999/66/ run.def.ref >! run.def ; run0 >>& error     #27
+# sed s/9999/65/ run.def.ref >! run.def ; run0 >>& error     #28
+# sed s/9999/60/ run.def.ref >! run.def ; run0 >>& error     #29
+# sed s/9999/54/ run.def.ref >! run.def ; run0 >>& error     #30
+# sed s/9999/50/ run.def.ref >! run.def ; run0 >>& error     #31
+# sed s/9999/46/ run.def.ref >! run.def ; run0 >>& error     #32
+# sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #33
+# sed s/9999/47/ run.def.ref >! run.def ; run0 >>& error     #34
+# sed s/9999/51/ run.def.ref >! run.def ; run0 >>& error     #35
+# sed s/9999/56/ run.def.ref >! run.def ; run0 >>& error     #36
+
+# These last lines allow to reconstruct the last num_run after a model crash 
+# (because after crash, num_run was set to 9999 so that no further simulation
+# Could be performed
+   set number=`cat num_run`
+   if ( $number == 99999) then
+      set numold=`cat num_run.crash`
+      echo '-----' >>& error
+      echo 'Seasonal simulation aborted after starting from start'$numold >>& error
+      \mv -f num_run.crash num_run  
+   endif
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/testphys1d.def
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/testphys1d.def	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/testphys1d.def	(revision 57)
@@ -0,0 +1,36 @@
+0      ! Initial day (martian sol; = 0 at Ls=0) 
+0      ! initial local time  (between 0 and 24) 
+48     ! number of time-step per day.
+100      ! Run duration (sols) 
+610.   ! psurf: Surface pressure (Pa) 
+0.2    ! tauref: reference dust opacity at 700 Pa (true tau~tauref*psurf/700)
+0.    ! latitude  (degrees) 
+0.2    ! ground albedo  (under the ice)
+400    ! ground thermal inertia  (SI)
+10.    ! composante vers l'est du vent geostrophique (u) 
+0.     ! composante vers le nord du vent geostrophique (v)
+0.     ! initial CO2 ice mass (kg.m-2)
+T      ! Hybrid vertical coordinate ? T=Hybrid , F=sigma 
+
+Initial temperature profile
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+5       ! ichoice :  Kind of initial profile (see below)
+200     ! tref : reference temperature (K) (used if ichoice=1)
+0       ! isin (if isin=1, add a perturbation to profile)
+26.5220 ! pic  pic perturbation gauss pour ichoice = 6 ou 7
+10      ! largeur de la perturbation gauss pour ichoice = 6 ou 7
+30.     ! hauteur de la perturbation gauss pour ichoice = 6 ou 7 
+
+c=======================================================================
+c   differents profils d'atmospheres. T=f(z)
+c         ichoice=1   Temperature constante T=tref
+c         ichoice=2   profil Savidjari (comme Seiff mais avec dT/dz=cte)
+c         ichoice=3   Lindner (profil polaire)
+c         ichoice=4   inversion
+c         ichoice=5   Seiff  (profile standard base sur les entrees Viking)
+c         ichoice=6    T constante + perturbation gauss (level)
+c         ichoice=7    T constante + perturbation gauss (km)
+c         ichoice=8   Read in an ascii file "profile" 
+
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+CECI EST LE FICHIER .DEF UTILISE EN 1D PAR TESTPHYS1D.F
Index: trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/z2sig.def
===================================================================
--- trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/z2sig.def	(revision 57)
+++ trunk/mesoscale/LMD_MM_MARS/SIMU/in_lmdz_mars/deftank/z2sig.def	(revision 57)
@@ -0,0 +1,68 @@
+10.00000     H: atmospheric scale height (km) (used as a reference only)
+0.0040       Typical pseudo-altitude (m) for 1st layer (z=H*log(sigma))
+0.018       ,, ,,  ,, ,, ,, ,,  ,, ,, ,,  2nd layer, etc...
+0.0400
+0.1000
+0.228200
+0.460400
+0.907000
+1.73630
+3.19040
+5.54010
+8.97780
+13.5138
+18.9666
+25.0626
+31.5527
+38.4369
+45.4369
+52.4369
+59.4369
+66.4369
+73.4369
+80.4369
+87.4369
+94.4369
+101.4369
+108.437
+115.437
+122.437
+129.437
+136.437
+143.437
+150.437
+157.437
+164.437
+171.437
+178.437
+185.437
+192.437
+199.437
+206.437
+213.437
+220.437
+227.437
+234.437
+241.437
+248.437
+255.437
+262.437
+269.437
+276.437
+283.437
+290.437
+297.437
+304.437
+311.437
+318.437
+325.437
+332.437
+339.437
+346.437
+353.437
+360.437
+367.437
+374.437
+381.437
+388.437
+395.437
